--- /dev/null
+# SQL Processing part for the Configuration Network File Format.
+# Programed by : Will Budic
+# Source Origin : https://github.com/wbudic/PerlCNF.git
+# Open Source License -> https://choosealicense.com/licenses/isc/
+#
+package CNFJSON;
+
+use strict;use warnings;#use warnings::unused;
+use Exception::Class ('CNFParserException'); use Carp qw(cluck);
+use Syntax::Keyword::Try;
+use JSON::ize;
+
+use constant VERSION => '1.0';
+
+sub new {
+ my ($class, $attrs,$self) = @_;
+ $self = {};
+ $self = \%$attrs if $attrs;
+ bless $self, $class;
+}
+###
+sub nodeToJSON {
+ my($self,$node,$tab_cnt) = @_; $tab_cnt=1 if !$tab_cnt;
+ if($self&&$node){
+ my ($buffer,$attributes,$closeBrk)=("","",0);
+ my $tab = $tab_cnt == 1 ? '' : ' ' x $tab_cnt;
+ my $name = $node -> {'_'};
+ my $val = $node -> {'#'}; $val = $node->{'*'} if !$val; $val = _translateNL($val);
+ my @arr = sort (keys %$node);
+ my $regex = $node->PRIVATE_FIELDS();
+ foreach my$attr(@arr){
+ if($attr !~ /$regex/){
+ my $aval = _translateNL($node->{$attr});
+ $attributes .= ",\n" if $attributes;
+ $attributes .= "$tab\"$attr\" : \"$aval\"";
+ }
+ }
+ #
+ @arr = exists $node-> {'@$'} ? @{$node -> {'@$'}} : ();
+ #
+ return \"$tab\"$name\" : \"$val\"" if(!@arr==0 && $val);
+ $tab_cnt++;
+ if(@arr){
+ foreach (@arr){
+ if (!$buffer){
+ $attributes.= ",\n" if $attributes;
+ $buffer = "$attributes$tab\"$name\" : {\n";
+ $attributes = ""; $closeBrk = 1;
+ }else{
+ $buffer .= ",\n"
+ }
+ my $sub = $_->name();
+ my $insert = nodeToJSON($self, $_, $tab_cnt);
+ if(length($$insert)>0){
+ $buffer .= $$insert;
+ }else{
+ $buffer .= $tab.(' ' x $tab_cnt)."\"$sub\" : {}"
+ }
+ }
+ }
+ if($attributes){
+ $closeBrk=2 if (!$buffer && !$node->isRoot());
+ $buffer .= $node->isRoot() ? "$tab$attributes" : "$tab\"$name\" : {\n$tab$attributes";
+ $attributes = "";
+ }
+ #
+ @arr = exists $node-> {'@@'} ? @{$node -> {'@@'}} : ();
+ #
+ if(@arr){
+ foreach (@arr){
+ if (!$attributes){
+ $attributes = "$tab\"$name\" : [\n"
+ }else{
+ $attributes .= ",\n"
+ }
+ $attributes .= $tab.(' ' x $tab_cnt).'"'.$_->val().'"'
+ }
+ $buffer .= $attributes."\n$tab]"
+ }
+ if ($closeBrk){
+ $buffer .= "\n$tab}"
+ }
+ if ($node->isRoot()){
+ $buffer =~ s/\n/\n /gs;
+ while (my ($k, $v) = each %$self) { $buffer .= qq(,\n"$k" : "$v") }
+ $buffer = $tab."{\n ".$buffer."\n"."$tab}";
+ }
+
+ return \$buffer
+
+ }else{
+ die "Where is the node, my friend?"
+ }
+}
+ sub _translateNL {
+ my $val = shift;
+ if($val){
+ $val =~ s/\n/\\n/g;
+ }
+ return $val
+ }
+
+sub jsonToCNFNode {
+ my($self,$json,$name) = @_;
+ if($self&&$json){
+ my $obj = jsonize($json);
+ return _objToCNF($name, $obj)
+ }
+ }
+ sub _jsonToObj {
+ return jsonize(shift);
+ }
+
+ sub _objToCNF {
+ my($name, $obj) = @_; $name = 'root' if !$name;
+ my $ret = CNFNode->new({'_'=>$name});
+ my %perl = %$obj;
+ foreach my $atrr(keys %perl){
+ my $val = $perl{$atrr};
+ my $ref = ref($val);
+ if($ref eq 'HASH'){
+ $val = _objToCNF($atrr, $val);
+ my @arr = $ret->{'@$'} ? $ret->{'@$'} : ();
+ $arr[@arr] = $val;
+ $ret->{'@$'} = \@arr;
+ }elsif($ref eq 'ARRAY'){
+ $ret->{'@$'} = \@$val
+ }else{
+ $ret -> {$atrr} = $val
+ }
+ }
+ return $ret;
+ }
+
+1;
\ No newline at end of file
###
# TREE instuction meta.
use constant HAS_PRIORITY => "HAS_PROCESSING_PRIORITY"; # Schedule to process before the rest in synchronous line of instructions.
+
#
###
# DO instruction meta.
#
use constant ON_DEMAND => "ON_DEMAND"; #Postpone to evaluate on demand.
use constant SHELL => "SHELL"; #Execute via system shell.
+
#
###
}
$constance;
}
+###
+# Priority order no. for instructions.
+use constant PRIORITY => qr/(\s*\_+PRIORITY\_(\d+)\_+\s*)/o;
+###
+# Tree instruction has been scripted in collapsed nodes shorthand format.
+# Shortife is parsed faster and with less recursion, but can be prone to script errors,
+# resulting in unintended placings.
+use constant IN_SHORTIFE => qr/(\s*\_+IN_SHORTIFE\_+\s*)/o;
sub import {
my $caller = caller; no strict "refs";
{
*{"${caller}::meta"} = \&_meta;
- *{"${caller}::HAS_PRIORITY"} = \&HAS_PRIORITY;
- *{"${caller}::ON_DEMAND"} = \&ON_DEMAND;
- *{"${caller}::SHELL"} = \&SHELL;
+ *{"${caller}::meta_has_priority"} = sub {return _meta(HAS_PRIORITY)};
+ *{"${caller}::meta_priority"} = \&PRIORITY;
+ *{"${caller}::meta_on_demand"} = sub {return _meta(ON_DEMAND)};
+ *{"${caller}::meta_node_in_shortife"} =\&IN_SHORTIFE;
+ *{"${caller}::SHELL"} = \&SHELL;
}
return 1;
}
my $self = \%$attrs;
bless $self, $class;
}
-sub name {shift -> {'_'}}
-sub parent {shift -> {'@'}}
-sub isRoot {not exists shift -> {'@'}}
-sub list {shift -> {'@@'}}
-sub script {shift -> {'~'}}
+
+use constant PRIVATE_FIELDS => qr/@\$|[@#_~^&]/o;
+
+###
+# CNFNode uses symbol offcodes for all its own field values, foe efficiancy.
+###
+sub name {shift -> {'_'}}
+sub parent {shift -> {'@'}}
+sub isRoot {not exists shift -> {'@'}}
+sub list {shift -> {'@@'}}
+sub script {shift -> {'~'}}
+sub priority {shift -> {'^'}}
+sub evaluate {shift -> {'&'}}
sub attributes {
my $self = shift;
my @nodes;
+ my $regex = PRIVATE_FIELDS();
foreach(sort keys %$self){
my $node = $self->{$_};
- if($_ !~ /@|@\$|#_~/){
+ if($_ !~ /$regex/){
$nodes[@nodes] = [$_, $node]
}
}
if(!$ret && $self->{'@$'}){ #return from subproperties.
my $buf;
my @arr = @{$self->{'@$'}};
- foreach my $node(@arr){
- $buf .= $node->val()."\n";
+ foreach my $node(@arr){
+ $buf .= $node -> val() ."\n";
}
return $buf;
}
# NOTICE - 20221222 Future versions might provide also for more complex path statements with regular expressions enabled.
###
sub find {
- my ($self, $path, $ret, $prev, $seekArray)=@_;
+ my ($self, $path, $ret, $prev, $seekArray,$ref)=@_;
foreach my $name(split(/\//, $path)){
if(ref($self) eq "ARRAY"){
if($name eq '#'){
$ret = $prev->{'@$'};
}
}else{
- if($name eq '@@') {
+ if ($name eq '@@') {
$ret = $self->{'@@'}; $seekArray = 1;
next
}elsif($name eq '@$') {
next
}elsif($name eq '#'){
return $ret->val()
- }if(ref($ret) eq "CNFNode" && $seekArray){
+ }elsif(exists $self->{$name}){
+ $ret = $self->{$name};
+ next
+ }
+ $ref = ref($ret);
+ if(!$seekArray && $ref eq 'ARRAY'){ # ret can be an array of parent same name elemenents.
+ foreach my$n(@$ret) {
+ if ($n->node($name)){
+ $ret = $n; last
+ }
+ }### TODO - Search further elements if not found. Many to many.
+ }elsif($ref eq "CNFNode" && $seekArray){
$ret = $ret->{$name};
next
}else{
$ret = $self->{'@$'} if ! $seekArray; # This will initiate further search in subproperties names.
}
}
- if($ret){
+ $ref = ref($ret);
+ if($ret && $ref eq 'ARRAY'){
my $found = 0;
my @arr;
undef $prev;
- foreach(@$ret){
- if($seekArray && exists $_->{'@$'}){
- my $n;
- foreach (@{$_->{'@$'}}){
- $n = $_;
- if ($n->{'_'} eq $name){
- $arr[@arr] = $n;
+ foreach my $ele(@$ret){
+ if($seekArray && exists $ele->{'@$'}){
+ foreach my$node(@{$ele->{'@$'}}){
+ if ($node->{'_'} eq $name){
+ $arr[@arr] = $ele = $node;
}
}
if(@arr>1){
$ret = \@arr;
- }else{
- $ret = $n;
+ }else{
+ $ret = $ele
}
$found++;
- }elsif (ref($_) eq "CNFNode" and $_->{'_'} eq $name){
- if($prev){
- $arr[@arr] = $_;
- $self = \@arr;
- $prev = $_;
- }else{
- $arr[@arr] = $_;
- $prev = $self = $_
- }
- if(!$found){
- $self = $ret = $_
- }else{
- $ret = \@arr;
+ }elsif (ref($ele) eq "CNFNode"){
+ if($ele->{'_'} eq $name){
+ if ($prev) {
+ $arr[@arr] = $ele;
+ $self = \@arr;
+ $prev = $ele;
+ }
+ else {
+ $arr[@arr] = $ele;
+ $prev = $self = $ele;
+ }
+ if ( !$found ) {
+ $self = $ret = $ele;
+ }
+ else {
+ $ret = \@arr;
+ }
+ $found = 1
+ }elsif(exists $ele->{$name}){
+ $ret = $ele->{$name};
+ $found = 1
}
- $found=1
}
}
- $ret = $self->{$name} if(!$found && $name ne '@$');
- }else{
- if(ref($ret) ne "ARRAY"){
- $ret = $self->{$name}
+ if(!$found && $name ne '@$' && exists $self->{$name}){
+ $ret = $self->{$name}
+ }else{
+ undef $ret if !$found
}
+ }
+ elsif($name && $ref eq "CNFNode"){
+ $ret = $ret -> {$name}
}
}
return $ret;
}
###
# Similar to find, put simpler node by path routine.
-# Returns first node found based on path..
+# Returns first node found based on path.
###
sub node {
my ($self, $path, $ret)=@_;
+ if($path !~ /\//){
+ return $self->{$path} if exists $self->{$path};
+ $ret = $self->{'@$'};
+ if($ret){
+ foreach(@$ret){
+ if ($_->{'_'} eq $path){
+ return $_;
+ }
+ }
+ }
+ return
+ }
foreach my $name(split(/\//, $path)){
$ret = $self->{'@$'};
if($ret){
sub process {
my ($self, $parser, $script)=@_;
- my ($sub, $val, $isArray,$body) = (undef,0,0,"");
- my ($tag,$sta,$end)=("","","");
+ my ($sub, $val, $isArray,$isShortifeScript,$body) = (undef,0,0,0,"");
+ my ($tag,$sta,$end)=("","",""); my $meta_shortife = &meta_node_in_shortife;
my ($opening,$closing,$valing)=(0,0,0);
my @array;
my @lines = split(/\n/, $script);
foreach my $ln(@lines){
$ln =~ s/^\s+|\s+$//g;
- if(length ($ln)){
- #print $ln, "\n";
+ if(length ($ln)){
+ my $isShortife = ($ln =~ s/($meta_shortife)/""/sexi);
if($ln =~ /^([<>\[\]])(.*)([<>\[\]])$/ && $1 eq $3){
$sta = $1;
$tag = $2;
- $end = $3;
+ $end = $3;
+ $isShortifeScript = 1 if $isShortife;
my $isClosing = ($sta =~ /[>\]]/) ? 1 : 0;
if($tag =~ /^([#\*\@]+)[\[<](.*)[\]>]\/*[#\*\@]+$/){#<- The \/ can sneak in as included in closing tag.
if($1 eq '*'){
my $link = $2;
- my $rval = $self -> obtainLink($parser, $link);
+ my $rval = $self -> obtainLink($parser, $link);
$rval = $parser->{$link} if !$rval; #Anon is passed as an unknown constance (immutable).
if($rval){
if($opening){
}
$valing = 0;
$tag ="" if $isClosing
- }else{
- my $a = $isArray;
- my $property = CNFNode->new({'_'=>$sub, '@' => \$self});
- $property -> process($parser, $body);
+ }else{
+ my $property = CNFNode->new({'_'=>$sub, '@' => \$self});
+ my $a = $isArray;
+ if($isShortifeScript){
+ my ($sub,$prev,$cnt_nl,$bck_p);
+ while ($body =~ / (.*)__+ ([\\\|]|\/*) | (.*)[:=](.*) | (.*)\n/gmx){
+ my @sel = @{^CAPTURE};
+ if(defined $sel[0]){
+ if ($sel[1]){
+ my $t = substr $sel[1],0,1;
+ $bck_p=length($sel[1]);
+ my $parent = $sub;
+ if($t eq '\\'){
+ $parent = $sub ? $sub : $property;
+ }elsif($t eq '|'){
+ $parent = $sub ? $sub->parent() : $prev;
+ }elsif($t eq '/') {
+ $parent = $sub;
+ do{$parent = $parent -> parent() if $parent -> parent()}while(--$bck_p>0);
+ if ($sel[0] eq ''){
+ $sub = $parent; next
+ }
+ }
+ $sub = CNFNode->new({'_'=>$sel[0], '@' => $parent});
+ my @elements = exists $parent -> {'@$'} ? $parent -> {'@$'} : ();
+ $elements[@elements] = $sub; $prev = $parent; $cnt_nl = 0;
+ $parent -> {'@$'} = \@elements;
+ }
+ }
+ elsif (defined $sel[2] && defined $sel[3]){
+ my $attribute = $sel[2]; $attribute =~ s/^\s*|\s*$//g;
+ my $value = $sel[3]; $value =~ s/^\s*|\s*$//g;
+ if($sub){
+ $sub -> {$attribute} = $value
+ }else{
+ $property -> {$attribute} = $value
+ }
+ $cnt_nl = 0;
+ }
+ elsif (defined $sel[4]){
+ if ($sel[4] eq ''){
+ if(++$cnt_nl>1){ #cancel collapse chain and at root of property that is shorted.
+ ##$sub = $property ;
+ $cnt_nl =0
+ }
+ next
+ }elsif($sel[4] !~ /^\s*\#/ ){
+ my $parent = $sub ? $sub->parent() : $property;
+ if (exists $parent->{'#'}){
+ $parent->{'#'} .= "\n" . $sel[4]
+ }else{
+ $parent->{'#'} = $sel[4]
+ }
+ # $sub ="";
+ }
+ }
+ }#while
+ $isShortifeScript = 0;
+ }else{
+ $property -> process($parser, $body);
+ }
$isArray = $a;
if($tag eq '@@'){
$array[@array] = $property;
else{$val = $4}
}elsif($2 eq '*'){
my $link = $4;
- my $rval = $self->obtainLink($parser, $link);
+ my $rval = $self -> obtainLink($parser, $link);
$rval = $parser->{$link} if !$rval; #Anon is passed as an unknown constance (immutable).
if($rval){
#Is this a child node?
$nodes[@nodes] = $property;
$self->{'@$'} = \@nodes;
}
-
next
}elsif($val){
$val = $self->{'#'};
my ($tag,$sta,$end,$lnc,$errors)=("","","",0,0);
my (@opening,@closing,@singels);
my ($open,$close) = (0,0);
- my @lines = split(/\n/, $self->{'~'});
+ my @lines = defined $self -> script() ? split(/\n/, $self->script()) :();
foreach my $ln(@lines){
$ln =~ s/^\s+|\s+$//g;
$lnc++;
#print $ln, "<-","\n";
if(length ($ln)){
#print $ln, "\n";
- if($ln =~ /^([<>\[\]])(.*)([<>\[\]])$/ && $1 eq $3){
+ if($ln =~ /^([<>\[\]])(.*)([<>\[\]])(.*)/ && $1 eq $3){
$sta = $1;
$tag = $2;
$end = $3;
}
}
}
- if(@opening != @closing){
- cluck "Opening and clossing tags mismatch!";
- foreach my $o(@opening){
+ if(@opening != @closing){
+ cluck "Opening and clossing tags mismatch!";
+ foreach my $o(@opening){
my $c = pop @closing;
if(!$c){
$errors++;
warn "Error unclosed tag-> [".$o->{T}.'[ @'.$o->{L}
}
- }
-
+ }
}else{
my $errors = 0; my $error_tag; my $nesting;
my $cnt = $#opening;
if($o->{T} ne $c->{T} && $o->{N} ne $c->{N}){
cluck "Error opening and clossing tags mismatch for ".
- brk($o).' ln: '.$o->{L}.' idx: '.$o->{idx}.
- ' wrongly matched with '.brk($c).' ln: '.$c->{L}.' idx: '.$c->{idx}."\n";
+ _brk($o).' ln: '.$o->{L}.' idx: '.$o->{idx}.
+ ' wrongly matched with '._brk($c).' ln: '.$c->{L}.' idx: '.$c->{idx}."\n";
$errors++;
}
}
return $errors;
}
-sub brk{
- my $t = shift;
- return 'tag: \''.$t->{S}.$t->{T}.$t->{S}.'\''
+ sub _brk{
+ my $t = shift;
+ return 'tag: \''.$t->{S}.$t->{T}.$t->{S}.'\''
+ }
+###
+# Compare one node with another if is equal in structure.
+##
+sub equals {
+ my ($self, $node, $ref) = @_; $ref = ref($node);
+ if (ref($node) eq 'CNFNode'){
+ my @s = sort keys %$self;
+ my @o = sort keys %$node;
+ my $i=$#o;
+ foreach (0..$i){
+ my $n = $o[$i-$_];
+ if($n eq '~' || $n eq '^'){
+ splice @o,$i-$_,1;
+ }
+ }
+ $i=$#s;
+ foreach (0..$i){
+ my $n = $s[$i-$_];
+ if($n eq '~' || $n=~/^CNF_/ || $n=~/^DO_/){
+ splice @s,$i-$_,1;
+ }
+ }$i=0;
+ if(@s == @o){
+ foreach(@s) {
+ if($_ ne $o[$i++]){
+ return 0
+ }
+ }
+ if($self -> {'@$'} && $node -> {'@$'}){
+ @s = sort keys @{$self -> {'@$'}};
+ @o = sort keys @{$node -> {'@$'}};
+ $i = 0;
+ foreach(@s) {
+ if($_ ne $o[$i++]){
+ return 0
+ }
+ }
+ }
+ return 1;
+ }
+ }
+ return 0;
}
1;
\ No newline at end of file
require CNFMeta; CNFMeta::import();
require CNFNode;
-require CNFtoJSON;
+
# Do not remove the following no critic, no security or object issues possible.
# We can use perls default behaviour on return.
##no critic qw(Subroutines::RequireFinalReturn)
##no critic Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions
-use constant VERSION => '2.8';
+use constant VERSION => '2.9';
our @files;
our %lists;
our %properties;
sub import {
my $caller = caller; no strict "refs";
{
- *{"${caller}::configDumpENV"} = \&dumpENV;
- *{"${caller}::anon"} = \&anon;
- *{"${caller}::SQL"} = \&SQL;
+ *{"${caller}::configDumpENV"} = \&dumpENV;
+ *{"${caller}::anon"} = \&anon;
+ *{"${caller}::SQL"} = \&SQL;
}
return 1;
}
+our $meta_has_priority = meta_has_priority();
+our $meta_priority = meta_priority();
+our $meta_on_demand = meta_on_demand();
+###
+# The metaverse is that further this can be expanded,
+# to provide further dynamic meta processing of the property value of an anon.
+# When the future becomes life in anonymity, unknown variables best describe the meta state.
+##
+package META_PROCESS {
+ sub constance{
+ my($class, $set) = @_;
+ if(!$set){
+ $set = {anonymous=>'*'}
+ }
+ bless $set, $class
+ }
+ sub process{
+ my($self, $property, $val) = @_;
+ if($self->{anonymous} ne '*'){
+ return $self->{anonymous}($property,$val)
+ }
+ return $val;
+ }
+}
+use constant META => META_PROCESS->constance();
+use constant META_TO_JSON => META_PROCESS->constance({anonymous=>*_to_JSON});
+sub _to_JSON {
+my($property, $val) = @_;
+return <<__JSON
+{"$property"="$val"}
+__JSON
+}
+
+
+
###
-# Post parsing instructed special item objects.
+# Post parsing instructed special item objects. They have lower priority to Order of apperance and from CNFNodes.
##
package InstructedDataItem {
- our $dataItemCounter = int(0);
+ our $dataItemCounter = int(0);
sub new { my ($class, $ele, $ins, $val) = @_;
- my $priority = ($val =~ s/CNFMETA::HAS_PRIORITY//sexi)?1:0;
+ my $priority = ($val =~ s/$meta_has_priority/""/sexi)?2:3; $val =~ s/$meta_priority/""/sexi;
+ $priority = $2 if $2;
bless {
ele => $ele,
aid => $dataItemCounter++,
ins => $ins,
val => $val,
- priority => $priority
+ '^' => $priority
}, $class
}
sub toString {
# PropertyValueStyle objects must have same rule of how an property body can be scripted for attributes.
##
package PropertyValueStyle {
+
sub new {
my ($class, $element, $script, $self) = @_;
$self = {} if not $self;
sub setPlugin{
my ($self, $obj) = @_;
$self->{plugin} = $obj;
- }
-
+ }
sub result {
my ($self, $value) = @_;
$self->{value} = $value;
}
#
-###
-# The metaverse is that further this can be expanded,
-# to provide further dynamic meta processing of the property value of an anon.
-# When the future becomes life in anonymity, unknown variables best describe the meta state.
-##
-package META_PROCESS {
- sub constance{
- my($class, $set) = @_;
- if(!$set){
- $set = {anonymous=>'*'}
- }
- bless $set, $class
- }
- sub process{
- my($self, $property, $val) = @_;
- if($self->{anonymous} ne '*'){
- return $self->{anonymous}($property,$val)
- }
- return $val;
- }
-}
-use constant META => META_PROCESS->constance();
-use constant META_TO_JSON => META_PROCESS->constance({anonymous=>*_to_JSON});
-sub _to_JSON {
-my($property, $val) = @_;
-return <<__JSON
-{"$property"="$val"}
-__JSON
-}
-
###
# Anon properties are public variables. Constance's are protected and instance specific, both config file provided (parsed in).
# Anon properties of an config instance are global by default, means they can also be statically accessed, i.e. CNFParser::anon(NAME)
#private to parser sub.
sub doInstruction { my ($self,$e,$t,$v) = @_;
- my $DO_ENABLED = $self->{'DO_ENABLED'};
+ my $DO_ENABLED = $self->{'DO_ENABLED'}; my $priority = 0;
$t = "" if not defined $t;
if($t eq 'CONST' or $t eq 'CONSTANT'){#Single constant with mulit-line value;
}elsif($t eq 'INCLUDE'){
$includes{$e} = {loaded=>0,path=>$e,v=>$v};
}elsif($t eq 'TREE'){
- my $tree = CNFNode->new({'_'=>$e,'~'=>$v});
+ my $tree = 0;
+ if (!$v){
+ $v = $e;
+ $e = 'LAST_DO';
+ }
+ if( $v =~ s/($meta_has_priority)/""/ei){
+ $priority = 1;
+ }
+ if( $v =~ s/$meta_priority/""/sexi){
+ $priority = $2;
+ }
+ $tree = CNFNode->new({'_'=>$e,'~'=>$v,'^'=>$priority});
$tree->{DEBUG} = 1 if $self->{DEBUG};
- $instructs{$e} = $tree;
+ $instructs{$e} = $tree;
}elsif($t eq 'TABLE'){ # This has now be late bound and send to the CNFSQL package. since v.2.6
SQL()->createTable($e,$v) } # It is hardly been used. But in future itt might change.
elsif($t eq 'INDEX'){ SQL()->createIndex($v)}
$v = $e;
$e = 'LAST_DO';
}
- my $meta = meta(ON_DEMAND());
- if($v=~ s/($meta)//i){
- $anons->{$e} = CNFNode -> new({'_'=>$e,'&'=>$v});
+ if( $v =~ s/($meta_has_priority)/""/ei){
+ $priority = 1;
+ }
+ if( $v =~ s/($meta_priority)/""/sexi){
+ $priority = $2;
+ }
+ if($v=~ s/($meta_on_demand)/""/ei){
+ $anons->{$e} = CNFNode -> new({'_'=>$e,'&'=>$v,'^'=>$priority});
return;
}
## no critic BuiltinFunctions::ProhibitStringyEval
}
}
elsif($t eq 'MACRO'){
- $instructs{$e}=$v;
-
+ $instructs{$e}=$v;
}else{
#Register application statement as either an anonymous one. Or since v.1.2 a listing type tag.
if($e !~ /\$\$$/){ #<- It is not matching {name}$$ here.
doInstruction($self,$e,$t,$v)
}
}
- #Do smart instructions and property linking.
- if(%instructs){
- my @ditms;
+ ### Do the smart instructions and property linking.
+ if(%instructs){
+ my @items;
foreach my $e(keys %instructs){
my $struct = $instructs{$e};
my $type = ref($struct);
}
$anons->{$e}=$v;
}else{
- $ditms[@ditms] = $struct;
+ $items[@items] = $struct;
}
}
- my @del; my $meta = meta(HAS_PRIORITY());
- for my $idx(0..$#ditms) {
- my $struct = $ditms[$idx];
+
+ @items = sort {$a->{'^'} <=> $b->{'^'}} @items; #sort by priority;
+
+ for my $idx(0..$#items) {
+ my $struct = $items[$idx];
my $type = ref($struct);
- if($type eq 'CNFNode' && ($struct->{'~'} =~ s/$meta//i)){ # This will trim out the flag within if found.
+ if($type eq 'CNFNode' && $struct-> priority() > 0){
$struct->validate() if $self->{ENABLE_WARNINGS};
- $anons ->{$struct->name()} = $struct->process($self, $struct->script());
- push @del, $idx;
+ $anons ->{$struct->name()} = $struct->process($self, $struct->script());
+ splice @items, $idx, 1
}
}
- while(@del){
- splice @ditms,pop @del, 1
- }
-
- for my $idx(0..$#ditms) {
- my $struct = $ditms[$idx];
+ #Now only what is left instructed data items or plugins, and nodes that have assigned last priority, if any.
+ for my $idx(0..$#items) {
+ my $struct = $items[$idx];
my $type = ref($struct);
if($type eq 'CNFNode'){
$struct->validate() if $self->{ENABLE_WARNINGS};
- $anons->{$struct->name()} = $struct->process($self, $struct->script());
- push @del, $idx;
- }elsif($type eq 'InstructedDataItem' && $struct->{'priority'} || $struct->{'val'} =~ s/$meta//i){
+ $anons->{$struct->name()} = $struct->process($self, $struct->script());
+ }elsif($type eq 'InstructedDataItem'){
my $t = $struct->{ins};
if($t eq 'PLUGIN'){
instructPlugin($self,$struct,$anons);
- }
- push @del, $idx;
- }
- }
- while(@del){
- splice @ditms,pop @del, 1
- }
-
- @ditms = sort {$a->{aid} <=> $b->{aid}} @ditms if $#ditms > 1;
- foreach my $struct(@ditms){
- my $type = ref($struct);
- if($type eq 'InstructedDataItem'){
- my $t = $struct->{ins};
- if($t eq 'PLUGIN'){
- instructPlugin($self,$struct,$anons);
- }else{
- warn "Undefined instruction detected: ".$struct->toString()
- }
- }
+ }
+ }else{warn "What is -> $struct type:$type ?"}
}
undef %instructs;
}
sub JSON {
my $self = shift;
if(!$JSON){
- require CNFtoJSON; $JSON = CNFtoJSON-> new();
+ require CNFJSON;
+ $JSON = CNFJSON-> new( {CNF_VERSION=>$self->{CNF_VERSION},
+ CNF_CONTENT=>$self->{CNF_CONTENT},
+ DO_ENABLED=>$self->{DO_ENABLED}
+ } );
}
return $JSON;
}
}
$arr = $link -> find('STYLE');
if(ref($arr) eq 'ARRAY'){
- foreach (@$arr){
+ foreach (@$arr){
$give_me .= "\n<style>\n".$_ -> val()."\n</style>\n"
}}else{
$give_me .= "\n<style>\n".$arr -> val()."\n</style>\n"
--- /dev/null
+###
+# HTML converter Plugin from PerlCNF to HTML from TREE instucted properties.
+# Processing of these is placed in the data parsers data.
+# Programed by : Will Budic
+# Notice - This source file is copied and usually placed in a local directory, outside of its project.
+# So it could not be the actual or current version, can vary or has been modiefied for what ever purpose in another project.
+# Please leave source of origin in this file for future references.
+# Source of Origin : https://github.com/wbudic/PerlCNF.git
+# Documentation : Specifications_For_CNF_ReadMe.md
+# Open Source Code License -> https://choosealicense.com/licenses/isc/
+#
+package HTMLProcessorPlugin;
+
+use strict;
+use warnings;
+use Syntax::Keyword::Try;
+use Exception::Class ('HTMLProcessorPluginException');
+use feature qw(signatures);
+use Scalar::Util qw(looks_like_number);
+use Date::Manip;
+
+sub new ($class, $fields={Language=>'English',DateFormat=>'US'}){
+
+ if(ref($fields) eq 'REF'){
+ warn "Hash reference required as argument for fields!"
+ }
+ my $lang = $fields->{'Language'};
+ my $frmt = $fields->{'DateFormat'};
+ Date_Init("Language=$lang","DateFormat=$frmt");
+
+ return bless $fields, $class
+}
+
+###
+# Process config data to contain expected fields and data.
+###
+sub convert ($self, $parser, $property) {
+ my ($bfHDR,$style,$jscript,$title, $link, $body_attrs, $header)=("","","","","","","");
+ $self->{CNFParser} = $parser;
+
+ my $tree = $parser->anon($property);
+ die "Tree property '$property' is not available!" if(!$tree or ref($tree) ne 'CNFNode');
+
+try{
+ $header = $parser-> {'HTTP_HEADER'} if exists $parser->{'HTTP_HEADER'};
+ $title = $tree -> {'Title'} if exists $tree->{'Title'};
+ $link = $tree -> {'HEADER'};
+ $body_attrs .= " ". $tree -> {'Body'} if exists $tree -> {'Body'};
+ if($link){
+ if(ref($link) eq 'CNFNode'){
+ my $arr = $link->find('CSS/@@');
+ foreach (@$arr){
+ my $v = $_->val();
+ $bfHDR .= qq(\t<link rel="stylesheet" type="text/css" href="$v" />\n);
+ }
+ $arr = $link->find('JS/@@');
+ foreach (@$arr){
+ my $v = $_->val();
+ $bfHDR .= qq(\t<script src="$v"></script>\n);
+ }
+ my $ps = $link -> find('STYLE');
+ $style = "\n<style>\n". $ps -> val()."</style>" if($ps);
+ $ps = $link -> find('JAVASCRIPT');
+ $jscript = "\n<script>\n". $ps -> val()."</script>" if($ps);
+ }
+
+ delete $tree -> {'HEADER'};
+ }
+
+ my $buffer = qq($header
+<!DOCTYPE html>
+<head>
+<title>$title</title>$bfHDR $style $jscript
+</head>
+);
+
+ $buffer .= qq(<body$body_attrs>\n<div class="main"><div class="divTableBody">\n);
+ foreach
+ my $node($tree->nodes()){
+ my $bf = build($parser, $node);
+ $buffer .= "$bf\n" if $node;
+ }
+ $buffer .= "\n</div></div>\n</body>\n</html>\n";
+
+ $parser->data()->{$property} = \$buffer;
+
+}catch{
+ HTMLProcessorPluginException->throw(error=>$@ ,show_trace=>1);
+}
+}
+#
+
+###
+# Builds the html version out of a CNFNode.
+# CNFNode with specific tags here are converted also here,
+# those that are out of the scope for normal standard HTML tags.
+# i.e. HTML doesn't have row and cell tags. Neither has meta links syntax.
+###
+sub build {
+ my $parser = shift;
+ my $node = shift;
+ my $tabs = shift; $tabs = 1 if !$tabs;
+ my $bf;
+ my $name = lc $node->name();
+ if(isParagraphName($name)){
+ $bf .= "\t"x$tabs."<div".placeAttributes($node).">\n"."\t"x$tabs."<div>";
+ foreach my $n($node->nodes()){
+ if($n->{'_'} ne '#'){
+ my $b = build($parser, $n, $tabs+1);
+ $bf .= "$b\n" if $b;
+ }
+ }
+ if($node->{'#'}){
+ my $v = $node->val();
+ $v =~ s/\n\n+/\<\/br>\n/gs;
+ $bf .= "\t<div>\n\t<p>\n".$v."</p>\n\t</div>\n";
+ }
+ $bf .= "\t</div>\t</div>\n"
+ }elsif( $name eq 'row' || $name eq 'cell' ){
+ $bf .= "\t"x$tabs."<div class=\"$name\"".placeAttributes($node).">\n";
+ foreach my $n($node->nodes()){
+ if($n->{'_'} ne '#'){
+ my $b = build($parser,$n,$tabs+1);
+ $bf .= "$b\n" if $b;
+ }
+ }
+ $bf .= $node->val()."\n" if $node->{'#'};
+ $bf .= "\t"x$tabs."</div>"
+ }elsif( $name eq 'img' ){
+ $bf .= "\t\t<img".placeAttributes($node)."/>\n";
+ }elsif($name eq 'list_images'){
+ my $paths = $node->{'@@'};
+ foreach my $ndp (@$paths){
+ my $path = $ndp -> val();
+ my @ext = split(',',"jpg,jpeg,png,gif");
+ my $exp = " ".$path."/*.". join (" ".$path."/*.", @ext);
+ my @images = glob($exp);
+ $bf .= "\t<div class='row'><div class='cell'><b>Directory: $path</b></div></div>";
+ foreach my $file(@images){
+ ($file=~/.*\/(.*)$/);
+ my $fn = $1;
+ my $enc = "img@".ShortLink::obtain($file);
+ $bf .= qq(\t<div class='row'><div class='cell'>);
+ $bf .= qq(\t<a href="$enc"><img src="$enc" with='120' height='120'><br>$fn</a>\n</div></div>\n);
+ }
+ }
+ }elsif($node->{'*'}){ #Links are already captured, in future this might be needed as a relink from here for dynamic stuff?
+ my $lval = $node->{'*'};
+ if($name eq 'file_list_html'){ #Special case where html links are provided.
+ foreach(split(/\n/,$lval)){
+ $bf .= qq( [ $_ ] |) if $_
+ }
+ $bf =~ s/\|$//g;
+ }else{ #Generic included link value.
+ #is there property data for it?
+ my $prop = $parser->data()->{$node->name()};
+ warn "Not found as property link -> ".$node->name() if !$prop;
+ if($prop){
+ $bf .= $$prop;
+ }else{
+ $bf .= $lval;
+ }
+ }
+ }
+ else{
+ $bf .= "\t"x$tabs."<".$node->name().placeAttributes($node).">";
+ foreach my $n($node->nodes()){
+ my $b = build($parser, $n,$tabs+1);
+ $bf .= "$b\n" if $b;
+ }
+ $bf .= $node->val() if $node->{'#'};
+ $bf .= "</".$node->name().">";
+
+ }
+ return $bf;
+}
+#
+
+
+sub placeAttributes {
+ my $node = shift;
+ my $ret = "";
+ my @attr = $node -> attributes();
+ foreach (@attr){
+ if(@$_[0] ne '#' && @$_[0] ne '_'){
+ if(@$_[1]){
+ $ret .= " ".@$_[0]."=\"".@$_[1]."\"";
+ }else{
+ $ret .= " ".@$_[0]." ";
+ }
+ }
+ }
+ return $ret;
+}
+
+sub isParagraphName {
+ my $name = shift;
+ return $name eq 'p' || $name eq 'paragraph' ? 1 : 0
+}
+
+
+
+1;
\ No newline at end of file
lifelog.hopto.org / LifeLog.git / commitdiff