From: Will Budic Date: Tue, 13 Jun 2023 22:28:51 +0000 (+1000) Subject: Imp. CNFMeta and CNFtoJSON. X-Git-Url: https://lifelog.hopto.org/gitweb/?a=commitdiff_plain;h=3ba768bd6d48e5e728a1e61abca303caba5ceb6b;p=LifeLog.git Imp. CNFMeta and CNFtoJSON. --- diff --git a/htdocs/cgi-bin/index.cgi b/htdocs/cgi-bin/index.cgi index ca30772..e45601d 100755 --- a/htdocs/cgi-bin/index.cgi +++ b/htdocs/cgi-bin/index.cgi @@ -16,10 +16,11 @@ use Exception::Class ('LifeLogException'); use Syntax::Keyword::Try; use DateTime; ## -# We is dynamic perl compilations. The following ONLY HERE required to carp to browser on +# We use dynamic perl compilations. The following ONLY HERE required to carp to browser on # system requirments or/and unexpected perl compiler errors. ## use CGI::Carp qw(fatalsToBrowser set_message); + BEGIN { sub handle_errors { my $err = shift; @@ -32,11 +33,10 @@ BEGIN { use lib "system/modules"; require CNFParser; require CNFNode; +require MarkdownPlugin; our $GLOB_HTML_SERVE = "'{}/*.cgi' '{}/*.htm' '{}/*.html' '{}/*.md' '{}/*.txt'"; -our $script_path = $0; -$script_path =~ s/\w+.cgi$//; - +our $script_path = $0; $script_path =~ s/\w+.cgi$//; exit &HTMLPageBuilderFromCNF; diff --git a/htdocs/cgi-bin/index.cnf b/htdocs/cgi-bin/index.cnf index c8f997e..00e896c 100644 --- a/htdocs/cgi-bin/index.cnf +++ b/htdocs/cgi-bin/index.cnf @@ -21,7 +21,6 @@ STYLE> +*> +>STYLE> + https://choosealicense.com/licenses/isc/ +# +package CNFMeta; + +use strict; +use warnings; + +### +# 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. +# + +### +# Returns the regular expresion for any of this meta constances. +## +sub _meta { + my $constance = shift; + if($constance){ + return qr/\s*\_+$constance\_+\s*/ + } + $constance; +} + +sub import { + my $caller = caller; no strict "refs"; + { + *{"${caller}::meta"} = \&_meta; + *{"${caller}::HAS_PRIORITY"} = \&HAS_PRIORITY; + *{"${caller}::ON_DEMAND"} = \&ON_DEMAND; + *{"${caller}::SHELL"} = \&SHELL; + } + return 1; +} + +1; \ No newline at end of file diff --git a/htdocs/cgi-bin/system/modules/CNFNode.pm b/htdocs/cgi-bin/system/modules/CNFNode.pm index eda4427..3f7677f 100644 --- a/htdocs/cgi-bin/system/modules/CNFNode.pm +++ b/htdocs/cgi-bin/system/modules/CNFNode.pm @@ -1,51 +1,91 @@ # # Represents a tree node CNF object having children and a parent node if it is not the root. # Programed by : Will Budic -# Source Origin : https://github.com/wbudic/PerlCNF.git -# Open Source License -> https://choosealicense.com/licenses/isc/ +# 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 CNFNode; use strict; use warnings; use Carp qw(cluck); +require CNFMeta; CNFMeta::import(); + sub new { - my ($class,$attrs, $self) = @_; - $self = \%$attrs; + my ($class, $attrs) = @_; + my $self = \%$attrs; bless $self, $class; } -sub name { +sub name {shift -> {'_'}} +sub parent {shift -> {'@'}} +sub isRoot {not exists shift -> {'@'}} +sub list {shift -> {'@@'}} +sub script {shift -> {'~'}} +sub attributes { my $self = shift; - return $self->{'_'} + my @nodes; + foreach(sort keys %$self){ + my $node = $self->{$_}; + if($_ !~ /@|@\$|#_~/){ + $nodes[@nodes] = [$_, $node] + } + } + return @nodes; +} +sub nodes { + my $self = shift; + my $ret = $self->{'@$'}; + if($ret){ + return @$ret; + } + return (); } + ### # Convenience method, returns string scalar value dereferenced (a copy) of the property value. ## sub val { my $self = shift; - my $ret = $self->{'#'}; - $ret = $self->{'*'} if !$ret; + my $ret = $self->{'#'}; # Standard value + $ret = $self->{'*'} if !$ret; # Linked value + $ret = _evaluate($self->{'&'}) if !$ret and exists $self->{'&'}; # Evaluated value + if(!$ret && $self->{'@$'}){ #return from subproperties. + my $buf; + my @arr = @{$self->{'@$'}}; + foreach my $node(@arr){ + $buf .= $node->val()."\n"; + } + return $buf; + } if(ref($ret) eq 'SCALAR'){ $ret = $$ret; - } + } return $ret } -sub parent { - my $self = shift; - return $self->{'@'} -} -sub attributes { - my $self = shift; - my @nodes; - foreach(sort keys %$self){ - my $node = $self->{$_}; - if($_ !~ /@|@\$|#_/){ - $nodes[@nodes] = [$_, $node] + my $meta = meta(SHELL()); + sub _evaluate { + my $value = shift; + if($value =~ s/($meta)//i){ + $value =~ s/^`|`\s*$/""/g; #we strip as a possible monkey copy had now redundant meta in the value. + $value = '`'.$value.'`'; + } + ## no critic BuiltinFunctions::ProhibitStringyEval + my $ret = eval $value; + ## use critic + if ($ret){ + chomp $ret; + return $ret; + }else{ + cluck("Perl DO_ENABLED script evaluation failed to evalute: $value Error: $@"); + return '<>'; } } - return @nodes; -} + # ### @@ -61,36 +101,34 @@ sub find { my ($self, $path, $ret, $prev, $seekArray)=@_; foreach my $name(split(/\//, $path)){ if(ref($self) eq "ARRAY"){ - if($name eq '#'){ - if(ref($ret) eq "ARRAY"){ - next - }else{ - return $prev->val() - } - }elsif($name =~ /\[(\d+)\]/){ + if($name eq '#'){ + if(ref($ret) eq "ARRAY"){ + next + }else{ + return $prev->val() + } + }elsif($name =~ /\[(\d+)\]/){ $self = $ret = @$ret[$1]; next - }else{ - #if(@$self == 1){ - $ret = $prev->{'@$'}; - # } - } + }else{ + $ret = $prev->{'@$'}; + } }else{ - if($name eq '@@') { - $ret = $self->{'@@'}; $seekArray = 1; - next - }elsif($name eq '@$') { - $ret = $self->{'@$'}; #This will initiate further search in subproperties names. - next - }elsif($name eq '#'){ - return $ret->val() - }if(ref($ret) eq "CNFNode" && $seekArray){ - $ret = $ret->{$name}; - next - }else{ - $ret = $self->{'@$'} if ! $seekArray; #This will initiate further search in subproperties names. - } + if($name eq '@@') { + $ret = $self->{'@@'}; $seekArray = 1; + next + }elsif($name eq '@$') { + $ret = $self->{'@$'}; # This will initiate further search in subproperties names. + next + }elsif($name eq '#'){ + return $ret->val() + }if(ref($ret) eq "CNFNode" && $seekArray){ + $ret = $ret->{$name}; + next + }else{ + $ret = $self->{'@$'} if ! $seekArray; # This will initiate further search in subproperties names. + } } if($ret){ my $found = 0; @@ -123,14 +161,16 @@ sub find { if(!$found){ $self = $ret = $_ }else{ - $ret = \@arr; + $ret = \@arr; } $found=1 } } $ret = $self->{$name} if(!$found && $name ne '@$'); }else{ - $ret = $self->{$name} ; + if(ref($ret) ne "ARRAY"){ + $ret = $self->{$name} + } } } return $ret; @@ -154,15 +194,6 @@ sub node { return $ret; } -sub nodes { - my $self = shift; - my $ret = $self->{'@$'}; - if($ret){ - return @$ret; - } - return (); -} - ### # Outreached subs list of collected node links found in a property. my @linked_subs; @@ -174,9 +205,9 @@ sub process { my ($self, $parser, $script)=@_; my ($sub, $val, $isArray,$body) = (undef,0,0,""); - my ($tag,$sta,$end)=("","",""); - my @array; + my ($tag,$sta,$end)=("","",""); my ($opening,$closing,$valing)=(0,0,0); + my @array; if(exists $self->{'_'} && $self->{'_'} eq '#'){ $val = $self->{'#'}; @@ -196,7 +227,7 @@ sub process { $tag = $2; $end = $3; my $isClosing = ($sta =~ /[>\]]/) ? 1 : 0; - if($tag =~ /^([#\*\@]+)[\[<](.*)[\]>]\/*[#\*\@]+$/){#<- The \/ can sneak in as included in closing tag. + if($tag =~ /^([#\*\@]+)[\[<](.*)[\]>]\/*[#\*\@]+$/){#<- The \/ can sneak in as included in closing tag. if($1 eq '*'){ my $link = $2; my $rval = $self -> obtainLink($parser, $link); @@ -215,7 +246,7 @@ sub process { @nodes = (); } $nodes[@nodes] = CNFNode->new({'_'=>$link, '*'=>$rval,'@' => \$self}); - $self->{'@$'} = \@nodes; + $self->{'@$'} = \@nodes; } else{ #Links scripted in main tree parent are copied main tree attributes. @@ -234,8 +265,7 @@ sub process { }else{ $val = $2; } - } - elsif($tag =~ /^(.*)[\[<]\/*(.*)[\]>](.*)$/ && $1 eq $3){ + }elsif($tag =~ /^(.*)[\[<]\/*(.*)[\]>](.*)$/ && $1 eq $3){ if($opening){ $body .= qq($ln\n) } @@ -252,12 +282,10 @@ sub process { $self->{'@$'} = \@nodes; } next - } - elsif($isClosing){ + }elsif($isClosing){ $opening--; $closing++; - } - else{ + }else{ $opening++; $closing--; } @@ -280,7 +308,7 @@ sub process { }else{ my $a = $isArray; my $property = CNFNode->new({'_'=>$sub, '@' => \$self}); - $property->process($parser, $body); + $property -> process($parser, $body); $isArray = $a; if($tag eq '@@'){ $array[@array] = $property; @@ -308,8 +336,7 @@ sub process { }elsif($tag eq '#'){ $valing = 1; }elsif($opening==0 && $isArray){ - $array[@array] = $ln; - # next + $array[@array] = $ln; }elsif($opening==0 && $ln =~ /^([<\[])(.+)([<\[])(.*)([>\]])(.+)([>\]])$/ && $1 eq $3 && $5 eq $7 ){ #<- tagged in line if($2 eq '#') { @@ -369,24 +396,28 @@ sub process { $array[@array] = $2; next; } - my @attr = ($ln =~m/([\s\w]*?)\s*[=:]\s*(.*)\s*/); + my @attr = ($ln =~ m/([\s\w]*?)\s*[=:]\s*(.*)\s*/); if(@attr>1){ my $n = $attr[0]; - my $v = $attr[1]; - $self->{$n} = $v; + my $v = $attr[1]; + if($v =~ /[<\[]\*[<\[](.*)[]>\]]\*[>\]]/){ + $v = $self-> obtainLink($parser, $1) + } $v =~ m/^(['"]).*(['"])$/g; + $v =~ s/^$1|$2$//g if($1 && $2 && $1 eq $2); + $self->{$n} = $v; next; }else{ $val = $ln if $val; } } - $body .= qq($ln\n) if $ln!~/^\#/ + # Very complex rule, allow #comment lines in buffer withing an node value tag, ie [#[..]#] + $body .= qq($ln\n) #if !$tag && $ln!~/^\#/ || $tag eq '#' } elsif($tag eq '#'){ - $body .= qq(\n) + $body .= qq(\n) } } } - $self->{'@@'} = \@array if @array; $self->{'#'} = \$val if $val; ## no critic BuiltinFunctions::ProhibitStringyEval @@ -395,7 +426,7 @@ sub process { my $entry = pop (@linked_subs); my $node = $entry->{node}; my $res = &{+$entry->{sub}}($node); - $entry->{node}->{'*'} = \$res; + $entry->{node}->{'*'} = \$res; } return \$self; } @@ -424,11 +455,11 @@ sub obtainLink { # Validates a script if it has correctly structured nodes. # sub validate { - my ($self, $script) = @_; + my $self = shift; my ($tag,$sta,$end,$lnc,$errors)=("","","",0,0); my (@opening,@closing,@singels); my ($open,$close) = (0,0); - my @lines = split(/\n/, $script); + my @lines = split(/\n/, $self->{'~'}); foreach my $ln(@lines){ $ln =~ s/^\s+|\s+$//g; $lnc++; @@ -470,8 +501,7 @@ sub validate { }else{ my $errors = 0; my $error_tag; my $nesting; my $cnt = $#opening; - for my $i (0..$cnt){ - + for my $i (0..$cnt){ my $o = $opening[$i]; my $c = $closing[$cnt - $i]; if($o->{T} ne $c->{T}){ diff --git a/htdocs/cgi-bin/system/modules/CNFParser.pm b/htdocs/cgi-bin/system/modules/CNFParser.pm index 256622c..2da7500 100644 --- a/htdocs/cgi-bin/system/modules/CNFParser.pm +++ b/htdocs/cgi-bin/system/modules/CNFParser.pm @@ -1,10 +1,11 @@ # Main Parser for the Configuration Network File Format. -# This source file is copied and usually placed in a local directory, outside of its project. -# So not the actual or current version, might vary or be modiefied for what ever purpose in other projects. # Programed by : Will Budic -# Source Origin : https://github.com/wbudic/PerlCNF.git +# 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 License -> https://choosealicense.com/licenses/isc/ +# Open Source Code License -> https://choosealicense.com/licenses/isc/ # package CNFParser; @@ -15,6 +16,10 @@ use Hash::Util qw(lock_hash unlock_hash); use Time::HiRes qw(time); use DateTime; +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) @@ -41,7 +46,7 @@ our %ANONS; our %RESERVED_WORDS = map +($_, 1), qw{ CONST CONSTANT VARIABLE VAR FILE TABLE TREE INDEX - VIEW SQL MIGRATE DO + VIEW SQL MIGRATE DO LIB PLUGIN MACRO %LOG INCLUDE INSTRUCTOR }; sub isReservedWord { my ($self, $word)=@_; return $word ? $RESERVED_WORDS{$word} : undef } @@ -54,7 +59,7 @@ our $CONSTREQ = 0; ### # Create a new CNFParser instance. -# $path - Path to some .cnf file, to parse, not compsuluory to add now. +# $path - Path to some .cnf_file file, to parse, not compsuluory to add now? Make undef. # $attrs - is reference to hash of constances and settings to dynamically employ. # $del_keys - is a reference to an array of constance attributes to dynamically remove. sub new { my ($class, $path, $attrs, $del_keys, $self) = @_; @@ -62,36 +67,39 @@ sub new { my ($class, $path, $attrs, $del_keys, $self) = @_; $self = \%$attrs; }else{ $self = { - DO_ENABLED => 0, # Enable/Disable DO instruction. Which could evaluated potentially be an doom execute destruction. - ANONS_ARE_PUBLIC=> 1, # Anon's are shared and global for all of instances of this object, by default. - ENABLE_WARNINGS => 1, # Disable this one, and you will stare into the void, on errors or operations skipped. - STRICT => 1, # Enable/Disable strict processing to FATAL on errors, this throws and halts parsing on errors. - HAS_EXTENSIONS => 0, # Enable/Disable extension of custom instructions. These is disabled by default and ingored. - DEBUG => 0 # Not internally used by the parser, but possible a convience bypass setting for code using it. + DO_ENABLED => 0, # Enable/Disable DO instruction. Which could evaluated potentially be an doom execute destruction. + ANONS_ARE_PUBLIC=> 1, # Anon's are shared and global for all of instances of this object, by default. + ENABLE_WARNINGS => 1, # Disable this one, and you will stare into the void, about errors or operations skipped. + STRICT => 1, # Enable/Disable strict processing to FATAL on errors, this throws and halts parsing on errors. + HAS_EXTENSIONS => 0, # Enable/Disable extension of custom instructions. These is disabled by default and ingored. + DEBUG => 0, # Not internally used by the parser, but possible a convience bypass setting for code using it. + CNF_CONTENT => "", # Origin of the script, this wull be set by the parser, usually the path of a script file or is direct content. }; } - $CONSTREQ = $self->{'CONSTANT_REQUIRED'}; - if (!$self->{'ANONS_ARE_PUBLIC'}){ #Not public, means are private to this object, that is, anons are not static. - $self->{'ANONS_ARE_PUBLIC'} = 0; #<- Caveat of Perl, if this is not set to zero, it can't be accessed legally in a protected hash. - $self->{'__ANONS__'} = {}; - } - $self->{'__DATA__'} = {}; - if(exists $self->{'%LOG'}){ + $CONSTREQ = $self->{CONSTANT_REQUIRED}; + if (!$self->{ANONS_ARE_PUBLIC}){ #Not public, means are private to this object, that is, anons are not static. + $self->{ANONS_ARE_PUBLIC} = 0; #<- Caveat of Perl, if this is not set to zero, it can't be accessed legally in a protected hash. + $self->{__ANONS__} = {}; + } + if(exists $self->{'%LOG'}){ if(ref($self->{'%LOG'}) ne 'HASH'){ die '%LOG'. "passed attribute is not an hash reference." }else{ $properties{'%LOG'} = $self->{'%LOG'} } } - $self->{'STRICT'} = 1 if not exists $self->{'STRICT'}; #make strict by default if missing. - $self->{'HAS_EXTENSIONS'} = 0 if not exists $self->{'HAS_EXTENSIONS'}; + $self->{STRICT} = 1 if not exists $self->{STRICT}; #make strict by default if missing. + $self->{ENABLE_WARNINGS} = 1 if not exists $self->{ENABLE_WARNINGS}; + $self->{HAS_EXTENSIONS} = 0 if not exists $self->{HAS_EXTENSIONS}; + $self->{CNF_VERSION} = VERSION; + $self->{__DATA__} = {}; bless $self, $class; $self->parse($path, undef, $del_keys) if($path); return $self; } # sub import { - my $caller = caller; + my $caller = caller; no strict "refs"; { *{"${caller}::configDumpENV"} = \&dumpENV; *{"${caller}::anon"} = \&anon; @@ -108,7 +116,7 @@ package InstructedDataItem { our $dataItemCounter = int(0); sub new { my ($class, $ele, $ins, $val) = @_; - my $priority = ($val =~ s/_HAS_PROCESSING_PRIORITY_//si)?1:0; + my $priority = ($val =~ s/CNFMETA::HAS_PRIORITY//sexi)?1:0; bless { ele => $ele, aid => $dataItemCounter++, @@ -124,8 +132,6 @@ package InstructedDataItem { } # - - ### # PropertyValueStyle objects must have same rule of how an property body can be scripted for attributes. ## @@ -251,8 +257,10 @@ sub anon { my ($self, $n, $args)=@_; warn "Scalar argument passed $args, did you mean array to pass? For property $n=$ret\n" unless $self and not $self->{ENABLE_WARNINGS} } - } - return $$ret if ref($ret) eq "REF"; + } + my $ref = ref($ret); + return $$ret if $ref eq "REF"; + return $ret->val() if $ref eq "CNFNode"; return $ret; } return $anechoic; @@ -370,7 +378,12 @@ sub doInstruction { my ($self,$e,$t,$v) = @_; if($t eq 'CONST' or $t eq 'CONSTANT'){#Single constant with mulit-line value; $v =~ s/^\s//; - $self->{$e} = $v if not $self->{$e}; # Not allowed to overwrite constant. + # Not allowed to overwrite constant. i.e. it could be DO_ENABLED which is restricted. + if (not $self->{$e}){ + $self->{$e} = $v if not $self->{$e}; + }else{ + warn "Skipped constant detected assignment for '$e'."; + } } elsif($t eq 'VAR' or $t eq 'VARIABLE'){ $v =~ s/^\s//; @@ -420,9 +433,9 @@ sub doInstruction { my ($self,$e,$t,$v) = @_; } }elsif($t eq 'FILE'){#@TODO Test case this - my ($i,$path,$cnf) = (0,"",$self->{CNF_CONTENT}); + my ($i,$path,$cnf_file) = (0,"",$self->{CNF_CONTENT}); $v=~s/\s+//g; - $path = substr($path, 0, rindex($cnf,'/')) .'/'.$v; + $path = substr($path, 0, rindex($cnf_file,'/')) .'/'.$v; push @files, $path; next if !$self->{'$AUTOLOAD_DATA_FILES'}; open(my $fh, "<:perlio", $path ) or CNFParserException->throw("Can't open $path -> $!"); @@ -486,8 +499,8 @@ sub doInstruction { my ($self,$e,$t,$v) = @_; }elsif($t eq 'INCLUDE'){ $includes{$e} = {loaded=>0,path=>$e,v=>$v}; }elsif($t eq 'TREE'){ - my $tree = CNFNode->new({'_'=>$e,script=>$v}); - $tree->{DEBUG} = $self->{DEBUG}; + my $tree = CNFNode->new({'_'=>$e,'~'=>$v}); + $tree->{DEBUG} = 1 if $self->{DEBUG}; $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. @@ -498,13 +511,48 @@ sub doInstruction { my ($self,$e,$t,$v) = @_; } elsif($t eq 'DO'){ if($DO_ENABLED){ - ## no critic BuiltinFunctions::ProhibitStringyEval - $v = eval $v; - ## use critic - chomp $v; $anons->{$e} = $v; + my $ret; + if (!$v){ + $v = $e; + $e = 'LAST_DO'; + } + my $meta = meta(ON_DEMAND()); + if($v=~ s/($meta)//i){ + $anons->{$e} = CNFNode -> new({'_'=>$e,'&'=>$v}); + return; + } + ## no critic BuiltinFunctions::ProhibitStringyEval + $ret = eval $v if not $ret; + ## use critic + if ($ret){ + chomp $ret; + $anons->{$e} = $ret; + }else{ + $self->warn("Perl DO_ENABLED script evaluation failed to evalute: $e Error: $@"); + $anons->{$e} = '<>'; + } }else{ $self->warn("DO_ENABLED is set to false to process property: $e\n") } + }elsif($t eq 'LIB'){ + if($DO_ENABLED){ + if (!$v){ + $v = $e; + $e = 'LAST_LIB'; + } + try{ + use Module::Load; + autoload $v; + $v =~ s/^(.*\/)*|(\..*)$//g; + $anons->{$e} = $v; + }catch{ + $self->warn("Module DO_ENABLED library failed to load: $v\n"); + $anons->{$e} = '<>'; + } + }else{ + $self->warn("DO_ENABLED is set to false to process a LIB property: $e\n"); + $anons->{$e} = '<>'; + } } elsif($t eq 'PLUGIN'){ if($DO_ENABLED){ @@ -554,7 +602,7 @@ sub doInstruction { my ($self,$e,$t,$v) = @_; ### # Parses a CNF file or a text content if specified, for this configuration object. ## -sub parse { my ($self, $cnf, $content, $del_keys) = @_; +sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; my @tags; if($self->{'ANONS_ARE_PUBLIC'}){ @@ -566,26 +614,27 @@ sub parse { my ($self, $cnf, $content, $del_keys) = @_; #private instructs on this parse call. %instructs = (); + # We control from here the constances, as we need to unlock them if previous parse was run. + unlock_hash(%$self); + if(not $content){ - open(my $fh, "<:perlio", $cnf ) or die "Can't open $cnf -> $!"; + open(my $fh, "<:perlio", $cnf_file ) or die "Can't open $cnf_file -> $!"; read $fh, $content, -s $fh; close $fh; - my @stat = stat($cnf); + my @stat = stat($cnf_file); $self->{CNF_STAT} = \@stat; - $self->{CNF_CONTENT} = $cnf; + $self->{CNF_CONTENT} = $cnf_file; }else{ my $type =Scalar::Util::reftype($content); if($type && $type eq 'ARRAY'){ $content = join "",@$content; $self->{CNF_CONTENT} = 'ARRAY'; - } + }else{$self->{CNF_CONTENT} = 'script'}; } $content =~ m/^\!(CNF\d+\.\d+)/; my $CNF_VER = $1; $CNF_VER="Undefined!" if not $CNF_VER; $self->{CNF_VERSION} = $CNF_VER if not defined $self->{CNF_VERSION}; - # We control from here the constances, need to unlock them if previous parse was run. - unlock_hash(%$self); my $spc = $content =~ /\n/ ? '(<{2,3}?)(<*.*?>*)(>{2,3})' : '(<{2,3}?)(<*.*?>*?)(>{2,3})$'; @tags = ($content =~ m/$spc/gms); @@ -594,11 +643,11 @@ sub parse { my ($self, $cnf, $content, $del_keys) = @_; next if not $tag; next if $tag =~ m/^(>+)|^(<<)/; if($tag =~ m/^<(\w*)\s+(.*?)>*$/gs){ # Original fastest and early format: <<>> - my $p = $1; + my $t = $1; my $v = $2; - if(isReservedWord($self,$p)){ - my $isVar = ($p eq 'VARIABLE' || $p eq 'VAR'); - if($p eq 'CONST' or $isVar){ #constant multiple properties. + if(isReservedWord($self,$t)){ + my $isVar = ($t eq 'VARIABLE' || $t eq 'VAR'); + if($t eq 'CONST' or $isVar){ #constant multiple properties. foreach my $line(split '\n', $v) { $line =~ s/^\s+|\s+$//; # strip unwanted spaces $line =~ s/\s*>$//; @@ -620,15 +669,12 @@ sub parse { my ($self, $cnf, $content, $del_keys) = @_; } } } - }else{ - my $t = $p; (m/(\w+)(.*)/s); - my $e = $1; - $v = $2; - doInstruction($self,$e,$t,$v); + }else{ + doInstruction($self,$v,$t,undef); } }else{ $v =~ s/\s*>$//; - $anons->{$p} = $v; + $anons->{$t} = $v; } }else{ @@ -784,14 +830,13 @@ sub parse { my ($self, $cnf, $content, $del_keys) = @_; $ditms[@ditms] = $struct; } } - my @del; + my @del; my $meta = meta(HAS_PRIORITY()); for my $idx(0..$#ditms) { my $struct = $ditms[$idx]; my $type = ref($struct); - if($type eq 'CNFNode' && ($struct->{'script'} =~ s/_HAS_PROCESSING_PRIORITY_//si)){ # This will within trim out the flag if found. - $struct->validate($struct->{'script'}) if $self->{ENABLE_WARNINGS}; - $anons->{$struct->{'_'}} = $struct->process($self, $struct->{'script'}); - #splice @ditms, $idx,1; <- causing havoc when key order is scrambled. Weirdest thing in perl! + if($type eq 'CNFNode' && ($struct->{'~'} =~ s/$meta//i)){ # This will trim out the flag within if found. + $struct->validate() if $self->{ENABLE_WARNINGS}; + $anons ->{$struct->name()} = $struct->process($self, $struct->script()); push @del, $idx; } } @@ -803,16 +848,16 @@ sub parse { my ($self, $cnf, $content, $del_keys) = @_; my $struct = $ditms[$idx]; my $type = ref($struct); if($type eq 'CNFNode'){ - $struct->validate($struct->{'script'}) if $self->{ENABLE_WARNINGS}; - $anons->{$struct->{'_'}} = $struct->process($self, $struct->{'script'}); + $struct->validate() if $self->{ENABLE_WARNINGS}; + $anons->{$struct->name()} = $struct->process($self, $struct->script()); push @del, $idx; - }elsif($type eq 'InstructedDataItem' && $struct->{'priority'}){ + }elsif($type eq 'InstructedDataItem' && $struct->{'priority'} || $struct->{'val'} =~ s/$meta//i){ my $t = $struct->{ins}; if($t eq 'PLUGIN'){ instructPlugin($self,$struct,$anons); - } + } push @del, $idx; - } + } } while(@del){ splice @ditms,pop @del, 1 @@ -825,6 +870,8 @@ sub parse { my ($self, $cnf, $content, $del_keys) = @_; my $t = $struct->{ins}; if($t eq 'PLUGIN'){ instructPlugin($self,$struct,$anons); + }else{ + warn "Undefined instruction detected: ".$struct->toString() } } } @@ -832,7 +879,7 @@ sub parse { my ($self, $cnf, $content, $del_keys) = @_; } #Do scripted includes. my @inc = sort values %includes; - $includes{$0} = {loaded=>1,path=>$self->{CNF_CONTENT}}; #<- to prevent circular includes. + $includes{$0} = {loaded=>1, path=>$self->{CNF_CONTENT}}; #<- to prevent circular includes. foreach my $file(@inc){ if(!$file->{loaded} && $file->{path} ne $self->{CNF_CONTENT}){ if(open(my $fh, "<:perlio", $file->{path} )){ @@ -1054,14 +1101,16 @@ sub writeOut { my ($self, $handle, $property) = @_; sub log { my $self = shift; my $message = shift; + my $type = shift; my $attach = join @_; $message .= $attach if $attach; my %log = $self -> collection('%LOG'); my $time = DateTime->from_epoch( epoch => time )->strftime('%Y-%m-%d %H:%M:%S.%3N'); - if($message =~ /^ERROR/){ - warn $time . " " . $message; + $message = "$type $message" if 'WARNG'; + if($message =~ /^ERROR/ || defined($type eq 'WARNG')){ + warn $time . " " .$message; } elsif(%log && $log{console}){ - print $time . " " . $message ."\n" + print $time . " " .$message ."\n" } if(%log && $log{enabled} && $message){ my $logfile = $log{file}; @@ -1089,13 +1138,9 @@ sub error { use Carp qw(cluck); #what the? I know... sub warn { my $self = shift; - my $message = shift; - my $time = DateTime->from_epoch( epoch => time )->strftime('%Y-%m-%d %H:%M:%S.%3N'); - $message = "$time WARNG $message\t".$self->{CNF_CONTENT}; + my $message = shift; if($self->{ENABLE_WARNINGS}){ - $self -> log($message) - }else{ - cluck $message + $self -> log($message,'WARNG'); } } sub trace { @@ -1121,6 +1166,15 @@ sub SQL { $SQL->addStatement(@_) if @_; return $SQL; } +our $JSON; +sub JSON { + my $self = shift; + if(!$JSON){ + require CNFtoJSON; $JSON = CNFtoJSON-> new(); + } + return $JSON; +} + sub END { undef %ANONS; diff --git a/htdocs/cgi-bin/system/modules/CNFtoJSON.pm b/htdocs/cgi-bin/system/modules/CNFtoJSON.pm new file mode 100644 index 0000000..c9f5e86 --- /dev/null +++ b/htdocs/cgi-bin/system/modules/CNFtoJSON.pm @@ -0,0 +1,102 @@ +# 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 CNFtoJSON; + +use strict;use warnings;#use warnings::unused; +use Exception::Class ('CNFParserException'); use Carp qw(cluck); +use Syntax::Keyword::Try; +use Time::HiRes qw(time); +use DateTime; + +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); + foreach (@arr){ + my $attr = $_; + if($attr !~ /@\$|[@+#_~]/){ + 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){ + $buffer .= $node->isRoot() ? "$tab$attributes" : "$tab\"$name\" : {\n$tab$attributes"; + $attributes = ""; $closeBrk=2; + } + # + @arr = exists $node-> {'@@'} ? @{$node -> {'@@'}} : (); + # + if(@arr){ + foreach (@arr){ + if (!$attributes){ + $attributes = "$tab\"$name\" : [\n" + }else{ + $buffer .= ",\n" + } + $buffer .= "\"$_\"\n" + } + $buffer .= $attributes."\n$tab]" + } + if ($closeBrk){ + $buffer .= "\n$tab}" + } + if($node->isRoot()){ + $buffer =~ s/\n/\n /gs; + $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 +} + + +1; \ No newline at end of file diff --git a/htdocs/cgi-bin/system/modules/HTMLIndexProcessorPlugin.pm b/htdocs/cgi-bin/system/modules/HTMLIndexProcessorPlugin.pm index cc86a2b..1df0a75 100644 --- a/htdocs/cgi-bin/system/modules/HTMLIndexProcessorPlugin.pm +++ b/htdocs/cgi-bin/system/modules/HTMLIndexProcessorPlugin.pm @@ -74,10 +74,20 @@ try{ foreach (@$arr){ push @hhshJS, {-type => 'text/javascript', -src => $_->val()}; } - my $ps = $link -> find('STYLE'); - $give_me .= "\n\n" if $ps; - $ps = $link -> find('SCRIPT'); - $give_me .="\n\n" if $ps; + $arr = $link -> find('STYLE'); + if(ref($arr) eq 'ARRAY'){ + foreach (@$arr){ + $give_me .= "\n\n" + }}else{ + $give_me .= "\n\n" + } + $arr = $link -> find('SCRIPT'); + if(ref($arr) eq 'ARRAY'){ + foreach (@$arr){ + $give_me .= "\n\n" + }}else{ + $give_me .= "\n\n" + } } delete $tree -> {'HEADER'}; }