From: Will Budic Date: Fri, 9 Jun 2023 02:00:58 +0000 (+1000) Subject: Upd. from PerlCNF. X-Git-Url: https://lifelog.hopto.org/gitweb/?a=commitdiff_plain;h=60f8ee2e4548c64b6ef8184aecf12968bbbd8c18;p=LifeLog.git Upd. from PerlCNF. --- diff --git a/htdocs/cgi-bin/system/modules/CNFNode.pm b/htdocs/cgi-bin/system/modules/CNFNode.pm index 83ab44e..eda4427 100644 --- a/htdocs/cgi-bin/system/modules/CNFNode.pm +++ b/htdocs/cgi-bin/system/modules/CNFNode.pm @@ -24,6 +24,7 @@ sub name { sub val { my $self = shift; my $ret = $self->{'#'}; + $ret = $self->{'*'} if !$ret; if(ref($ret) eq 'SCALAR'){ $ret = $$ret; } @@ -34,14 +35,13 @@ sub parent { return $self->{'@'} } - sub attributes { my $self = shift; my @nodes; foreach(sort keys %$self){ my $node = $self->{$_}; if($_ !~ /@|@\$|#_/){ - $nodes[@nodes] = [$_, $node] + $nodes[@nodes] = [$_, $node] } } return @nodes; @@ -49,7 +49,7 @@ sub attributes { # ### -# Search a path for node from a path statement. +# Search select nodes based on from a path statement. # It will always return an array for even a single subproperty. # The reason is several subproperties of the same name can be contained by the parent property. # It will return an array of list values with (@@). @@ -135,7 +135,10 @@ sub find { } return $ret; } -# +### +# Similar to find, put simpler node by path routine. +# Returns first node found based on path.. +### sub node { my ($self, $path, $ret)=@_; foreach my $name(split(/\//, $path)){ @@ -150,6 +153,7 @@ sub node { } return $ret; } + sub nodes { my $self = shift; my $ret = $self->{'@$'}; @@ -158,6 +162,11 @@ sub nodes { } return (); } + +### +# Outreached subs list of collected node links found in a property. +my @linked_subs; + ### # The parsing guts of the CNFNode, that from raw script, recursively creates and tree of nodes from it. ### @@ -179,8 +188,7 @@ sub process { }else{ my @lines = split(/\n/, $script); foreach my $ln(@lines){ - $ln =~ s/^\s+|\s+$//g; - #print $ln, "<-","\n"; + $ln =~ s/^\s+|\s+$//g; if(length ($ln)){ #print $ln, "\n"; if($ln =~ /^([<>\[\]])(.*)([<>\[\]])$/ && $1 eq $3){ @@ -191,9 +199,9 @@ sub process { if($tag =~ /^([#\*\@]+)[\[<](.*)[\]>]\/*[#\*\@]+$/){#<- The \/ can sneak in as included in closing tag. if($1 eq '*'){ my $link = $2; - my $lval = $parser->anon($2); - $lval = $parser->{$2} if !$lval; #Anon is passed as an unknown constance (immutable). - if($lval){ + my $rval = $self -> obtainLink($parser, $link); + $rval = $parser->{$link} if !$rval; #Anon is passed as an unknown constance (immutable). + if($rval){ if($opening){ $body .= qq($ln\n); }else{ @@ -206,12 +214,12 @@ sub process { }else{ @nodes = (); } - $nodes[@nodes] = CNFNode->new({'_'=>$link, '*'=>$lval,'@' => \$self}); + $nodes[@nodes] = CNFNode->new({'_'=>$link, '*'=>$rval,'@' => \$self}); $self->{'@$'} = \@nodes; } else{ #Links scripted in main tree parent are copied main tree attributes. - $self->{$link} = $lval + $self->{$link} = $rval } } next @@ -268,6 +276,7 @@ sub process { $val .= $body } $valing = 0; + $tag ="" if $isClosing }else{ my $a = $isArray; my $property = CNFNode->new({'_'=>$sub, '@' => \$self}); @@ -308,9 +317,9 @@ sub process { else{$val = $4} }elsif($2 eq '*'){ my $link = $4; - my $lval = $parser->anon($4); - $lval = $parser->{$4} if !$lval; #Anon is passed as an unknown constance (immutable). - if($lval){ + 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? if(exists $self->{'@'}){ my @nodes; @@ -320,16 +329,16 @@ sub process { }else{ @nodes = (); } - $nodes[@nodes] = CNFNode->new({'_'=>$link, '*'=>$lval, '@' => \$self}); + $nodes[@nodes] = CNFNode->new({'_'=>$link, '*'=>$rval, '@' => \$self}); $self->{'@$'} = \@nodes; } else{ #Links scripted in main tree parent are copied main tree attributes. - $self->{$link} = $lval + $self->{$link} = $rval } }else{ - warn "Anon link $link not located with $ln for node ".$self->{'_'} if !$opening; + warn "Anon link $link not located with '$ln' for node ".$self->{'_'} if !$opening; } }elsif($2 eq '@@'){ $array[@array] = CNFNode->new({'_'=>$2, '#'=>$4, '@' => \$self}); @@ -370,7 +379,7 @@ sub process { $val = $ln if $val; } } - $body .= qq($ln\n) + $body .= qq($ln\n) if $ln!~/^\#/ } elsif($tag eq '#'){ $body .= qq(\n) @@ -380,9 +389,40 @@ sub process { $self->{'@@'} = \@array if @array; $self->{'#'} = \$val if $val; + ## no critic BuiltinFunctions::ProhibitStringyEval + no strict 'refs'; + while(@linked_subs){ + my $entry = pop (@linked_subs); + my $node = $entry->{node}; + my $res = &{+$entry->{sub}}($node); + $entry->{node}->{'*'} = \$res; + } return \$self; } +sub obtainLink { + my ($self,$parser,$link, $ret) = @_; + ## no critic BuiltinFunctions::ProhibitStringyEval + no strict 'refs'; + if($link =~/(.*)(\(\.\))$/){ + push @linked_subs, {node=>$self,link=>$link,sub=>$1}; + return 1; + }elsif($link =~/(\w*)::\w+$/){ + use Module::Loaded qw(is_loaded); + if(is_loaded($1)){ + $ret = \&{+$link}($self); + }else{ + cluck qq(Package constance link -> $link is not available (try to place in main:: package with -> 'use $1;')") + } + }else{ + $ret = $parser->anon($link); + } + return $ret; +} + +### +# Validates a script if it has correctly structured nodes. +# sub validate { my ($self, $script) = @_; my ($tag,$sta,$end,$lnc,$errors)=("","","",0,0); diff --git a/htdocs/cgi-bin/system/modules/CNFParser.pm b/htdocs/cgi-bin/system/modules/CNFParser.pm index 3ded854..256622c 100644 --- a/htdocs/cgi-bin/system/modules/CNFParser.pm +++ b/htdocs/cgi-bin/system/modules/CNFParser.pm @@ -17,7 +17,8 @@ use DateTime; # 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,ControlStructures::ProhibitMutatingListFunctions); +##no critic qw(Subroutines::RequireFinalReturn) +##no critic Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions use constant VERSION => '2.8'; our @files; @@ -37,9 +38,12 @@ our %ANONS; # CNF Instruction tag covered reserved words. # You probably don't want to use these as your own possible instruction implementation. ### -our %RESERVED_WORDS = (CONST=>1, CONSTANT=>1, VARIABLE=>1, VAR=>1, FILE=>1, TABLE=>1, TREE=>1, - INDEX=>1, VIEW=>1, SQL=>1, MIGRATE=>1, - DO=>1, PLUGIN=>1, MACRO=>1,'%LOG'=>1, INCLUDE=>1, INSTRUCTOR=>1); + +our %RESERVED_WORDS = map +($_, 1), qw{ CONST CONSTANT VARIABLE VAR + FILE TABLE TREE INDEX + VIEW SQL MIGRATE DO + PLUGIN MACRO %LOG INCLUDE INSTRUCTOR }; + sub isReservedWord { my ($self, $word)=@_; return $word ? $RESERVED_WORDS{$word} : undef } ### @@ -365,16 +369,12 @@ sub doInstruction { my ($self,$e,$t,$v) = @_; $t = "" if not defined $t; 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. - } elsif($t eq 'VAR' or $t eq 'VARIABLE'){ - $v =~ s/^\s//; - $anons->{$e} = $v; - + $anons->{$e} = $v; } elsif($t eq 'DATA'){ $v=~ s/^\n//; @@ -872,16 +872,6 @@ sub instructPlugin { } } -our $SQL; -sub SQL { - if(!$SQL){##It is late compiled on demand. - require CNFSQL; $SQL = CNFSQL->new(); - } - $SQL->addStatement(@_) if @_; - return $SQL; -} - - ### # Register Instructor on tag and value for to be externally processed. # $package - Is the anonymouse package name. @@ -969,6 +959,7 @@ sub doPlugin { } } +### # Writes out to a handle an CNF property or this parsers constance's as default property. # i.e. new CNFParser()->writeOut(*STDOUT); sub writeOut { my ($self, $handle, $property) = @_; @@ -1122,6 +1113,14 @@ sub dumpENV{ foreach (keys(%ENV)){print $_,"=", "\'".$ENV{$_}."\'", "\n"} } +our $SQL; +sub SQL { + if(!$SQL){##It is late compiled on demand. + require CNFSQL; $SQL = CNFSQL->new(); + } + $SQL->addStatement(@_) if @_; + return $SQL; +} sub END { undef %ANONS; diff --git a/htdocs/cgi-bin/system/modules/PerlKeywords.pm b/htdocs/cgi-bin/system/modules/PerlKeywords.pm new file mode 100644 index 0000000..e14967c --- /dev/null +++ b/htdocs/cgi-bin/system/modules/PerlKeywords.pm @@ -0,0 +1,118 @@ +package PerlKeywords; +use strict; use warnings; +use Exporter; +our @ISA = 'Exporter'; +our @EXPORT = 'span_to_html'; +our @EXPORT_OK = qw(%RESERVED_WORDS %KEYWORDS %FUNCTIONS @REG_EXP &matchForCSS &CAP); + +our %RESERVED_WORDS = map +($_, 1), qw{ CONST CONSTANT VARIABLE VAR + FILE TABLE TREE INDEX + VIEW SQL MIGRATE DO + PLUGIN MACRO %LOG INCLUDE INSTRUCTOR }; + + +our %KEYWORDS = map +($_, 1), qw{ + bless caller continue dbmclose dbmopen die do dump else elsif eval exit + for foreach goto if import last local my next no our package redo ref + require return sub tie tied unless untie until use wantarray while + given when default + try catch finally + has extends with before after around override augment +}; + + + our %FUNCTIONS = map +($_, 1), qw{ + abs accept alarm atan2 bind binmode chdir chmod chomp chop chown chr + chroot close closedir connect cos crypt defined delete each endgrent + endhostent endnetent endprotoent endpwent endservent eof exec exists + exp fcntl fileno flock fork format formline getc getgrent getgrgid + getgrnam gethostbyaddr gethostbyname gethostent getlogin getnetbyaddr + getnetbyname getnetent getpeername getpgrp getppid getpriority + getprotobyname getprotobynumber getprotoent getpwent getpwnam getpwuid + getservbyname getservbyport getservent getsockname getsockopt glob + gmtime grep hex index int ioctl join keys kill lc lcfirst length link + listen localtime lock log lstat map mkdir msgctl msgget msgrcv msgsnd + oct open opendir ord pack pipe pop pos print printf prototype push + quotemeta rand read readdir readline readlink readpipe recv rename + reset reverse rewinddir rindex rmdir scalar seek seekdir select semctl + semget semop send setgrent sethostent setnetent setpgrp setpriority + setprotoent setpwent setservent setsockopt shift shmctl shmget shmread + shmwrite shutdown sin sleep socket socketpair sort splice split sprintf + sqrt srand stat study substr symlink syscall sysopen sysread sysseek + system syswrite tell telldir time times tr truncate uc ucfirst umask + undef unlink unpack unshift utime values vec wait waitpid warn write + say +}; + + + +our @REG_EXP = ( + { + regex=> qr/(['"])(.*)(['"])/, + css=> 'string' + }, + { + regex => qr/(\s*#.*)$/o, + css => 'comments' + } +); + +our @LAST_CAPTURED; +sub CAP{ + return \@LAST_CAPTURED; +} + +### +# Match regular expression to appropriate style sheet class name. +# @deprecated This will not be employed as we are only interested from this package in from perl to HTML. +### +sub matchForCSS { + my $string = shift; + if($string){ + foreach(@REG_EXP){ + my $current = $_; + if($string =~ $current -> {regex}){ + @LAST_CAPTURED = @{^CAPTURE}; + return $current -> {css} + } + } + } + return; +} +### +# Translate any code script int HTML colored version for output to the silly browser. +### +sub span_to_html { my ($script,$css, $code_tag_contain) = @_; if($css .=" "){}else{$css=""} # $css if specified we need to give it some space in its short life. + my $out; + my $SPC = " "; + my $SPAN = qq($tkns[1]) + }elsif($3) { $out .= $SPAN.qq(Q">$tkns[2]) + }elsif($4) { + if (exists $KEYWORDS{$4}){ $out .= $SPAN.qq(K">$tkns[3]) + }elsif(exists $FUNCTIONS{$4}){ $out .= $SPAN.qq(F">$tkns[3]) + }else{ $out .= $SPAN.qq($tkns[3]) + } + }elsif($5){ $out .= $SPAN.qq(O">$tkns[4]) + } + } + $out .= "
\n"; + } + if($code_tag_contain){ + if($code_tag_contain == 1) { + $out = "\n".$out."\n" + }else{ + $out = "<$code_tag_contain>\n".$out."\n" + } + } +return \$out; +} + + + +1; \ No newline at end of file