From e07233db611fe65dc1ddbff7a4d9519342a9c093 Mon Sep 17 00:00:00 2001 From: Will Budic Date: Fri, 17 Nov 2023 13:12:02 +1100 Subject: [PATCH] upd. with latest from PerlCNF. --- AAA_TEST.txt | 1 - htdocs/cgi-bin/system/modules/CNFJSON.pm | 19 ++- htdocs/cgi-bin/system/modules/CNFMeta.pm | 1 + htdocs/cgi-bin/system/modules/CNFParser.pm | 60 ++++--- .../system/modules/DataProcessorPlugin.pm | 126 +++++++++++++++ .../modules/DataProcessorWorldCitiesPlugin.pm | 88 +++++++++++ .../modules/HTMLIndexProcessorPlugin.pm | 147 ++++++------------ .../system/modules/HTMLProcessorPlugin.pm | 51 +++--- 8 files changed, 345 insertions(+), 148 deletions(-) delete mode 100644 AAA_TEST.txt create mode 100644 htdocs/cgi-bin/system/modules/DataProcessorPlugin.pm create mode 100644 htdocs/cgi-bin/system/modules/DataProcessorWorldCitiesPlugin.pm diff --git a/AAA_TEST.txt b/AAA_TEST.txt deleted file mode 100644 index 08d196d..0000000 --- a/AAA_TEST.txt +++ /dev/null @@ -1 +0,0 @@ -added to test mods to lifelog.hopto.org diff --git a/htdocs/cgi-bin/system/modules/CNFJSON.pm b/htdocs/cgi-bin/system/modules/CNFJSON.pm index 8954ba3..51e944e 100644 --- a/htdocs/cgi-bin/system/modules/CNFJSON.pm +++ b/htdocs/cgi-bin/system/modules/CNFJSON.pm @@ -1,8 +1,6 @@ +### # 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; @@ -132,4 +130,15 @@ sub jsonToCNFNode { return $ret; } -1; \ No newline at end of file +1; + +=begin copyright +Programed by : Will Budic +EContactHash : 990MWWLWM8C2MI8K (https://github.com/wbudic/EContactHash.md) +Source : https://github.com/wbudic/PerlCNF.git +Documentation : Specifications_For_CNF_ReadMe.md + This source file is copied and usually placed in a local directory, outside of its repository 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. +Open Source Code License -> https://github.com/wbudic/PerlCNF/blob/master/ISC_License.md +=cut copyright \ No newline at end of file diff --git a/htdocs/cgi-bin/system/modules/CNFMeta.pm b/htdocs/cgi-bin/system/modules/CNFMeta.pm index 2571eb1..e56910f 100644 --- a/htdocs/cgi-bin/system/modules/CNFMeta.pm +++ b/htdocs/cgi-bin/system/modules/CNFMeta.pm @@ -40,6 +40,7 @@ sub import { *{"${caller}::meta_on_demand"} = sub {return _meta("ON_DEMAND")}; # Process or load last (includes0. *{"${caller}::meta_process_last"} = sub {return _meta("PROCESS_LAST")}; + *{"${caller}::meta_const"} = sub {return _meta("CONST")}; ### # 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, diff --git a/htdocs/cgi-bin/system/modules/CNFParser.pm b/htdocs/cgi-bin/system/modules/CNFParser.pm index 1c1a609..24ff05f 100644 --- a/htdocs/cgi-bin/system/modules/CNFParser.pm +++ b/htdocs/cgi-bin/system/modules/CNFParser.pm @@ -95,7 +95,7 @@ sub new { my ($class, $path, $attrs, $del_keys, $self) = @_; $self->{CNF_VERSION} = VERSION; $self->{__DATA__} = {}; undef $SQL; - bless $self, $class; $self->parse($path, undef, $del_keys) if($path); + bless $self, $class; $self -> parse($path, undef, $del_keys) if($path); return $self; } # @@ -116,6 +116,7 @@ our $meta_has_priority = meta_has_priority(); our $meta_priority = meta_priority(); our $meta_on_demand = meta_on_demand(); our $meta_process_last = meta_process_last(); +our $meta_const = meta_const(); ### @@ -290,7 +291,10 @@ sub anon { my ($self, $n, $args)=@_; # Returns undef if it doesn't exist, and exception if constance required is set; sub const { my ($self,$c)=@_; return $self->{$c} if exists $self->{$c}; - CNFParserException->throw("Required constants variable ' $c ' not defined in config!") if $CONSTREQ; + if ($CONSTREQ){CNFParserException->throw("Required constants variable ' $c ' not defined in config!")} + # Let's try to resolve. As old convention makes constances have a '$' prefix all upprercase. + $c = '$'.$c; + return $self->{$c} if exists $self->{$c}; return; } @@ -679,7 +683,7 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; $anons = $self->{'__ANONS__'}; } - # We control from here the constances, as we need to unlock them if previous parse was run. + # We control from here the constances, as we need to unlock them if a previous parse was run. unlock_hash(%$self); if(not $content){ @@ -716,25 +720,28 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; 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*>$//; - $line =~ m/([\$\w]*)(\s*=\s*)(.*)/g; - my $name = $1; - $line = $3; $line =~ s/^\s*(['"])(.*)\g{1}$/$2/ if $line;#strip quotes - if(defined $name){ - if($isVar){ - $anons ->{$name} = $line if $line - }else{ - if($line and not $self->{$name}){# Not allowed to overwrite constant. - $self->{$name} = $line; - }else{ - warn "Skipping and keeping previously set constance -> [$name] the new value ". - ($line eq $self->{$name})?"matches it":"dosean't match -> $line." - } + foreach my $line(split '\n', $v) { + my $isMETAConst = $line =~ s/$meta_const//se; + $line =~ s/^\s+|\s+$//; # strip unwanted spaces + $line =~ s/\s*>$//; + $line =~ m/([\$\w]*)(\s*=\s*)(.*)/g; + my $name = $1; + $line = $3; $line =~ s/^\s*(['"])(.*)\g{1}$/$2/ if $line;#strip quotes + if(defined $name){ + if($isVar && not $isMETAConst){ + $anons ->{$name} = $line if $line + }else{ + $name =~ s/^\$// if $isMETAConst; + # It is NOT allowed to overwrite a constant, so check an issue warning. + if($line and not $self->{$name}){ + $self->{$name} = $line; + }else{ my + $w = "Skipping and keeping a previously set constance of -> [$name] in ". $self->{CNF_CONTENT}." the new value "; + $w .= ($line eq $self->{$name})?"matches it":"dosean't match -> $line."; $self->warn($w) } } - } + } + } }else{ doInstruction($self,$v,$t,undef); } @@ -813,6 +820,7 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; # $t = $1; # $v = $2; # } + my $IsConstant = ($v =~ s/$meta_const/""/sexi); my @lst = ($isArray?split(/[,\n]/, $v):split('\n', $v)); $_=""; my @props = map { s/^\s+|\s+$//; # strip unwanted spaces @@ -836,7 +844,7 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; my $macro = 0; if(exists($properties{$t})){ if($self->isReservedWord($t)){ - $self->warn("Skipped overwritting reserved property -> $t."); + $self->warn("Skipped a try to overwrite a reserved property -> $t."); next }else{ %hsh = %{$properties{$t}} @@ -851,6 +859,12 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; next if (@pair != 2 || $pair[0] =~ m/^[#\\\/]+/m);#skip, it is a comment or not '=' delimited line. my $name = $pair[0]; my $value = $pair[1]; $value =~ s/^\s*["']|['"]$//g;#strip quotes + if($IsConstant && $p =~ m/\$[A-Z]+/){# if meta constant we check $p if signified to transfer into a CNF constance. + if(not exists $self->{$name}){ + $self->{$name} = $value; + next; + } + } if($macro){ my @arr = ($value =~ m/(\$\$\$.+?\$\$\$)/gm); foreach my $find(@arr) { @@ -941,7 +955,7 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; delete $self->{$k} if exists $self->{$k} } my $runProcessors = $self->{RUN_PROCESSORS} ? 1: 0; - lock_hash(%$self);#Make repository finally immutable. + $self = lock_hash(%$self);#Make repository finally immutable. runPostParseProcessors($self) if $runProcessors; if ($LOG_TRIM_SUB){ $LOG_TRIM_SUB->(); @@ -1295,7 +1309,7 @@ sub log { $message = "$type $message" if $isWarning; - if($message =~ /^ERROR/ || $isWarning){ + if($message =~ /^ERROR/ || ($isWarning && $self->{ENABLE_WARNINGS})){ warn $time . " " .$message; } elsif(%log && $log{console}){ diff --git a/htdocs/cgi-bin/system/modules/DataProcessorPlugin.pm b/htdocs/cgi-bin/system/modules/DataProcessorPlugin.pm new file mode 100644 index 0000000..d872b9d --- /dev/null +++ b/htdocs/cgi-bin/system/modules/DataProcessorPlugin.pm @@ -0,0 +1,126 @@ +package DataProcessorPlugin; + +use strict; +use warnings; + +use feature qw(signatures); +use Scalar::Util qw(looks_like_number); +use Clone qw(clone); +use Date::Manip; + +use constant VERSION => '1.0'; + +sub new ($class, $plugin){ + my $settings; + if($plugin){ + $settings = clone $plugin; #clone otherwise will get hijacked with blessings. + } + return bless $settings, $class +} + +### +# Process config data to contain expected fields and data. +### +sub process ($self, $parser, $property) { + my @data = $parser->data()->{$property}; +# +# The sometime unwanted side of perl is that when dereferencing arrays, +# modification only is visible withing the scope of the block. +# Following processes and creates new references on modified data. +# And is the reason why it might look ugly or has some unecessary relooping. +# + for my $did (0 .. $#data){ + my @entry = @{$data[$did]}; + my $ID_Spec_Size = 0; + my @SPEC; + my $mod = 0; + foreach (@entry){ + my @row = @$_; + $ID_Spec_Size = scalar @row; + for my $i (0..$ID_Spec_Size-1){ + if($row[$i] =~ /^#/){ + $SPEC[$i] = 1; + } + elsif($row[$i] =~ /^@/){ + $SPEC[$i] = 2; + } + else{ + $SPEC[$i] = 3; + } + }#rof + if($row[0]){ + # Cleanup header label row for the columns, if present. + shift @entry; + #we are done spec obtained from header just before. + last + } + } + my $size = $#entry; + my $padding = length($size); + for my $eid (0 .. $size){ + my @row = @{$entry[$eid]}; + if ($ID_Spec_Size){ + # If zero it is presumed ID field, corresponding to row number + 1 is our assumed autonumber. + if($row[0] == 0){ + my $times = $padding - length($eid+1); + $row[0] = zero_prefix($times,$eid+1); + $mod = 1 + } + if(@row!=$ID_Spec_Size){ + warn "Row data[$eid] doesn't match expect column count: $ID_Spec_Size\n @row"; + }else{ + for my $i (1..$ID_Spec_Size-1){ + if(not matchType($SPEC[$i], $row[$i])){ + warn "Row in row[$i]='$row[$i]' doesn't match expect data type, contents: @row"; + } + elsif($SPEC[$i]==2){ + my $dts = $row[$i]; + my $dt = UnixDate(ParseDateString($dts), "%Y-%m-%d %T"); + if($dt){ $row[$i] = $dt; $mod = 1 }else{ + warn "Row in row[$i]='$dts' has imporper date format, contents: @row"; + } + }else{ + my $v = $row[$i]; + $v =~ s/^\s+|\s+$//gs; + $row[$i] =$v; + } + } + } + $entry[$eid]=\@row if $mod; #<-- re-reference as we changed the row. Something hard to understand. + } + } + $data[$did]=\@entry if $mod; + } + $parser->data()->{$property} = \@data; +} +sub zero_prefix ($times, $val) { + if($times>0){ + return '0'x$times.$val; + }else{ + return $val; + } +} +sub matchType($type, $val, @rows) { + if ($type==1 && looks_like_number($val)){return 1} + elsif($type==2){ + if($val=~/\d*\/\d*\/\d*/){return 1} + else{ + return 1; + } + } + elsif($type==3){return 1} + return 0; +} + +1; + +=begin copyright +Programed by : Will Budic +EContactHash : 990MWWLWM8C2MI8K (https://github.com/wbudic/EContactHash.md) +Source : https://github.com/wbudic/PerlCNF.git +Documentation : Specifications_For_CNF_ReadMe.md + This source file is copied and usually placed in a local directory, outside of its repository 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. +Open Source Code License -> https://github.com/wbudic/PerlCNF/blob/master/ISC_License.md +=cut copyright \ No newline at end of file diff --git a/htdocs/cgi-bin/system/modules/DataProcessorWorldCitiesPlugin.pm b/htdocs/cgi-bin/system/modules/DataProcessorWorldCitiesPlugin.pm new file mode 100644 index 0000000..04c9fb2 --- /dev/null +++ b/htdocs/cgi-bin/system/modules/DataProcessorWorldCitiesPlugin.pm @@ -0,0 +1,88 @@ +package DataProcessorWorldCitiesPlugin; + +use strict; +use warnings; + +use feature qw(signatures); +use Scalar::Util qw(looks_like_number); + + +sub new ($class,$plugin){ + return bless {}, $class +} + +### +# Process config data to contain expected fields and data. +### +sub process ($self, $parser, $property) { + + my @data = $parser->data()->{$property}; + + for my $did (0 .. $#data){ + my @entry = @{$data[$did]}; + my $Spec_Size = 0; + my $mod = 0; + # Cleanup header labels row. + shift @entry; + } + $parser->data()->{$property} = \@data; +} + +### +# Process config data directly from a raw data file containing no Perl CNF tags. +# This is prefered way if your data is over, let's say 10 000 rows. +### + +sub loadAndProcess ($self, $parser, $property) { + + my @data; + local $/ = undef; + my $file = $parser->anon($property); + open my $fh, '<', $file or die ("$!"); + foreach(split(/~\n/,<$fh>)){ + my @a; + $_ =~ s/\\`/\\f/g;#We escape to form feed the found 'escaped' backtick so can be used as text. + foreach my $d (split /`/, $_){ + $d =~ s/\\f/`/g; #escape back form feed to backtick. + $d =~ s/~$//; #strip dangling ~ if there was no \n + my $t = substr $d, 0, 1; + if($t eq '$'){ + my $v = $d; #capture spected value. + $d =~ s/\$$|\s*$//g; #trim any space and system or constant '$' end marker. + if($v=~m/\$$/){ + $v = $self->{$d}; $v="" if not $v; + } + else{ + $v = $d; + } + push @a, $v; + } + else{ + if($t =~ /^\#(.*)/) {#First is usually ID a number and also '#' signifies number. + $d = $1;#substr $d, 1; + $d=0 if !$d; #default to 0 if not specified. + push @a, $d + } + else{ + push @a, $d; + } + } + } + $data[@data]= \@a; + } + close $fh; + $parser->data()->{$property} = \@data; +} + +1; + +=begin copyright +Programed by : Will Budic +EContactHash : 990MWWLWM8C2MI8K (https://github.com/wbudic/EContactHash.md) +Source : https://github.com/wbudic/PerlCNF.git +Documentation : Specifications_For_CNF_ReadMe.md + This source file is copied and usually placed in a local directory, outside of its repository 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. +Open Source Code License -> https://github.com/wbudic/PerlCNF/blob/master/ISC_License.md +=cut copyright \ 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 f92cc76..afce2c1 100644 --- a/htdocs/cgi-bin/system/modules/HTMLIndexProcessorPlugin.pm +++ b/htdocs/cgi-bin/system/modules/HTMLIndexProcessorPlugin.pm @@ -26,61 +26,34 @@ sub new ($class, $plugin){ ### # Process config data to contain expected fields and data. ### -sub convert ($self, $parser, $property) { +sub convert ($self, $parser, $property) { my ($buffer,$title, $link, $body_attrs, $body_on_load, $give_me); my $cgi = CGI -> new(); - my $cgi_action = $cgi-> param('action'); - my $cgi_doc = $cgi-> param('doc'); + my $cgi_action = $cgi-> param('action'); + my $cgi_doc = $cgi-> param('doc'); my $tree = $parser-> anon($property); - die "Tree property '$property' is not available!" if(!$tree or ref($tree) ne 'CNFNode'); + die "Tree property '$property' is not available!" if(!$tree or ref($tree) ne 'CNFNode'); + try{ - #TODO 20231002 Move -> %WEBAPP_SETTINGS into utility. - my %THEME; - my %wsettings = $parser -> collection('%WEBAPP_SETTINGS'); - if(%wsettings){ - my $theme = $wsettings{THEME}; - my @els = split(/, /, $theme); - foreach (@els) { - my ($key,$val) = split(/\s*=>\s*/, $_); - $THEME{$key} = $val; - last if $key eq 'css' - } - my $theme_file = $wsettings{LOG_PATH}.'current_theme'; - $theme_file =~ /^\.\.\/\.\.\// if(-e $theme_file); - if(-e $theme_file){ - open my $fh, '<', $theme_file; - my $theme = <$fh>; - close($fh); - if($theme =~ m/standard/i){ - $THEME{css} = "wsrc/main.css" - }elsif($theme =~ m/moon/i){ - $THEME{css} = "wsrc/main_moon.css" - } - elsif($theme =~ m/sun/i){ - $THEME{css} = "wsrc/main_sun.css" - } - elsif($theme =~ m/earth/i){ - $THEME{css} = "wsrc/main_earth.css" - } - } - } - if (exists $parser->{'HTTP_HEADER'}){ + + if (exists $parser->{'HTTP_HEADER'}){ $buffer .= $parser-> {'HTTP_HEADER'}; - }else{ + }else{ if(exists $parser -> collections()->{'%HTTP_HEADER'}){ my %http_hdr = $parser -> collection('%HTTP_HEADER'); $buffer = $cgi->header(%http_hdr); } } - if ($cgi_action and $cgi_action eq 'load'){ - $buffer .= $cgi->start_html(); my + + if ($cgi_action and $cgi_action eq 'load'){ + $buffer .= $cgi->start_html(); my $load = loadDocument($parser, $cgi_doc); if($load){ - $buffer .= $$load if $load; + $buffer .= $$load if $load; }else{ $buffer .= "Document is empty: $cgi_doc\n" - } + } }else{ $title = $tree -> {'Title'} if exists $tree->{'Title'}; $link = $tree -> {'HEADER'}; @@ -91,17 +64,13 @@ try{ if($link){ if(ref($link) eq 'CNFNode'){ my $arr = $link->find('CSS/@@'); - foreach (@$arr){ - if($THEME{css} && $_->val() =~ /main.css$/){ - push @hhshCSS, {-type => 'text/css', -src => $THEME{css}}; - }else{ - push @hhshCSS, {-type => 'text/css', -src => $_->val()}; - } + foreach (@$arr){ + push @hhshCSS, {-type => 'text/css', -src => $_->val()}; } $arr = $link->find('JS/@@'); - foreach (@$arr){ - push @hhshJS, {-type => 'text/javascript', -src => $_->val()}; - } + foreach (@$arr){ + push @hhshJS, {-type => 'text/javascript', -src => $_->val()}; + } $arr = $link -> find('STYLE'); if(ref($arr) eq 'ARRAY'){ foreach (@$arr){ @@ -111,65 +80,51 @@ try{ } $arr = $link -> find('SCRIPT'); if(ref($arr) eq 'ARRAY'){ - foreach (@$arr){ - my $attributes = _nodeHTMLAtrributes($_); - $give_me .= "\n\n".$_ -> val()."\n\n" + foreach (@$arr){ + $give_me .= "\n\n" }}else{ - my $attributes = _nodeHTMLAtrributes($arr); - $give_me .= "\n\n".$arr -> val()."\n\n"; - + $give_me .= "\n\n" } - } - delete $tree -> {'HEADER'}; - } + } + delete $tree -> {'HEADER'}; + } $buffer .= $cgi->start_html( -title => $title, -onload => $body_on_load, - # -BGCOLOR => $colBG, + # -BGCOLOR => $colBG, -style => \@hhshCSS, -script => \@hhshJS, -head=>$give_me, $body_attrs ); - foreach my $node($tree->nodes()){ + foreach my $node($tree->nodes()){ $buffer .= build($parser, $node) if $node; } $buffer .= $cgi->end_html(); } $parser->data()->{$property} = \$buffer; }catch($e){ - HTMLIndexProcessorPluginException->throw(error=>$e); + HTMLIndexProcessorPluginException->throw(error=>$e ,show_trace=>1); } } - -sub _nodeHTMLAtrributes { - my $node = shift; - my $attributes =" "; - my @attrs = $node -> attributes(); - foreach my $a(@attrs){ - $attributes .= @$a[0] . " = \"" .@$a[1]."\"" - } - $attributes = "" if $attributes eq " "; - return $attributes -} # sub loadDocument($parser, $doc) { my $slurp = do { - open my $fh, '<:encoding(UTF-8)', $doc or HTMLIndexProcessorPluginException->throw(error=>"Document not avaliable -> \"$doc\" ", show_trace=>1); + open my $fh, '<:encoding(UTF-8)', $doc or HTMLIndexProcessorPluginException->throw("Document not avaliable: $doc"); local $/; - <$fh>; + <$fh>; }; if($doc =~/\.md$/){ - require MarkdownPlugin; - my @r = @{MarkdownPlugin->new(undef)->parse($slurp)}; + require MarkdownPlugin; + my @r = @{MarkdownPlugin->new()->parse($slurp)}; return $r[0]; } - return \$slurp + return \$slurp } ### # Builds the html version out of a CNFNode. -# CNFNode with specific tags here are converted also here, +# 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. ### @@ -183,14 +138,14 @@ sub build { $bf .= "\t"x$tabs."\n"."\t"x$tabs."
"; foreach my $n($node->nodes()){ if($n->{'_'} ne '#'){ - my $b = build($parser, $n, $tabs+1); + 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
\n\t

\n".$v."

\n\t
\n"; + $bf .= "\t
\n\t

\n".$v."

\n\t
\n"; } $bf .= "\t
\t\n" }elsif( $name eq 'row' || $name eq 'cell' ){ @@ -201,13 +156,13 @@ sub build { $bf .= "$b\n" if $b; } } - $bf .= $node->val()."\n" if $node->{'#'}; + $bf .= $node->val()."\n" if $node->{'#'}; $bf .= "\t"x$tabs."" }elsif( $name eq 'img' ){ $bf .= "\t\t\n"; }elsif($name eq 'list_images'){ my $paths = $node->{'@@'}; - foreach my $ndp (@$paths){ + foreach my $ndp (@$paths){ my $path = $ndp -> val(); my @ext = split(',',"jpg,jpeg,png,gif"); my $exp = " ".$path."/*.". join (" ".$path."/*.", @ext); @@ -220,22 +175,22 @@ sub build { $bf .= qq(\t
); $bf .= qq(\t
$fn\n
\n); } - } + } }elsif($name eq '!'){ return "\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. + 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()}; + my $prop = $parser->data()->{$node->name()}; #if not has it been passed as an page constance? - $prop = $parser -> {$node->name()} if !$prop; + $prop = $parser -> {$node->name()} if !$prop; if ( !$prop ) { if ( $parser->{STRICT} ) { die "Not found as property link -> " . $node->name()} else { warn "Not found as property link -> " . $node->name()} @@ -254,20 +209,20 @@ sub build { } else{ my $spaced = 1; - $bf .= "\t"x$tabs."<".$node->name().placeAttributes($node).">"; - foreach my $n($node->nodes()){ - my $b = build($parser, $n,$tabs+1); - if ($b){ + $bf .= "\t"x$tabs."<".$node->name().placeAttributes($node).">"; + foreach my $n($node->nodes()){ + my $b = build($parser, $n,$tabs+1); + if ($b){ if($b =~/\n/){ $bf =~ s/\n$//gs; $bf .= "\n$b\n" }else{ - $spaced=0; - $bf .= $b; + $spaced=0; + $bf .= $b; } - } + } } - + if ($node->{'#'}){ $bf .= $node->val(); $bf .= "name().">"; @@ -292,7 +247,7 @@ sub placeAttributes { if(@$_[0] ne '#' && @$_[0] ne '_'){ if(@$_[1]){ $ret .= " ".@$_[0]."=\"".@$_[1]."\""; - }else{ + }else{ $ret .= " ".@$_[0]." "; } } diff --git a/htdocs/cgi-bin/system/modules/HTMLProcessorPlugin.pm b/htdocs/cgi-bin/system/modules/HTMLProcessorPlugin.pm index b455f23..2977a31 100644 --- a/htdocs/cgi-bin/system/modules/HTMLProcessorPlugin.pm +++ b/htdocs/cgi-bin/system/modules/HTMLProcessorPlugin.pm @@ -1,14 +1,7 @@ ### # 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; @@ -17,20 +10,16 @@ use Syntax::Keyword::Try; use Exception::Class ('HTMLProcessorPluginException'); use feature qw(signatures); use Scalar::Util qw(looks_like_number); -use Date::Manip; +use Clone qw(clone); use constant VERSION => '1.0'; -sub new ($class, $fields={Language=>'English',DateFormat=>'US'}){ - - if(ref($fields) eq 'REF'){ - warn "Hash reference required as argument for fields!" +sub new ($class, $plugin){ + my $settings; + if($plugin){ + $settings = clone $plugin; #clone otherwise will get hijacked with blessings. } - my $lang = $fields->{'Language'}; - my $frmt = $fields->{'DateFormat'}; - Date_Init("Language=$lang","DateFormat=$frmt"); - - return bless $fields, $class + return bless $settings, $class } ### @@ -60,10 +49,15 @@ try{ my $v = $_->val(); $bfHDR .= qq(\t\n); } - my $ps = $link -> find('STYLE'); - $style = "\n" if($ps); - $ps = $link -> find('JAVASCRIPT'); - $jscript = "\n" if($ps); + # Glob find '/*' now has guaranteed array cast derefence return. Even if nothing found. Some folks will cringe on that. Ahahaha! + $arr = $link -> find('STYLE/*'); + foreach (@$arr){ + $style = "\n" + } + $arr = $link -> find('JAVASCRIPT/*'); + foreach (@$arr){ + $jscript = "\n" + } } delete $tree -> {'HEADER'}; @@ -202,4 +196,15 @@ sub isParagraphName { -1; \ No newline at end of file +1; + +=begin copyright +Programed by : Will Budic +EContactHash : 990MWWLWM8C2MI8K (https://github.com/wbudic/EContactHash.md) +Source : https://github.com/wbudic/PerlCNF.git +Documentation : Specifications_For_CNF_ReadMe.md + This source file is copied and usually placed in a local directory, outside of its repository 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. +Open Source Code License -> https://github.com/wbudic/PerlCNF/blob/master/ISC_License.md +=cut copyright \ No newline at end of file -- 2.34.1