sub val {
my $self = shift;
my $ret = $self->{'#'};
+ $ret = $self->{'*'} if !$ret;
if(ref($ret) eq 'SCALAR'){
$ret = $$ret;
}
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;
#
###
-# 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 (@@).
}
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)){
}
return $ret;
}
+
sub nodes {
my $self = shift;
my $ret = $self->{'@$'};
}
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.
###
}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){
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{
}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
$val .= $body
}
$valing = 0;
+ $tag ="" if $isClosing
}else{
my $a = $isArray;
my $property = CNFNode->new({'_'=>$sub, '@' => \$self});
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;
}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});
$val = $ln if $val;
}
}
- $body .= qq($ln\n)
+ $body .= qq($ln\n) if $ln!~/^\#/
}
elsif($tag eq '#'){
$body .= qq(\n)
$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);
# 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;
# 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 }
###
$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//;
}
}
-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.
}
}
+###
# 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) = @_;
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;
--- /dev/null
+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(<span class="$css);
+ foreach my $line(split /\n/, $script){
+ while($line =~ /(\s+)|(\$\w+)|(['"])|(\w+)|(\W+)/gm){
+
+ my @tkns = @{^CAPTURE};
+ if ($1) { $out .= $SPC x length($1)
+ }elsif($2) { $out .= $SPAN.qq(V">$tkns[1]</span>)
+ }elsif($3) { $out .= $SPAN.qq(Q">$tkns[2]</span>)
+ }elsif($4) {
+ if (exists $KEYWORDS{$4}){ $out .= $SPAN.qq(K">$tkns[3]</span>)
+ }elsif(exists $FUNCTIONS{$4}){ $out .= $SPAN.qq(F">$tkns[3]</span>)
+ }else{ $out .= $SPAN.qq($tkns[3]</span>)
+ }
+ }elsif($5){ $out .= $SPAN.qq(O">$tkns[4]</span>)
+ }
+ }
+ $out .= "<br>\n";
+ }
+ if($code_tag_contain){
+ if($code_tag_contain == 1) {
+ $out = "<code>\n".$out."\n</code>"
+ }else{
+ $out = "<$code_tag_contain>\n".$out."\n</$code_tag_contain>"
+ }
+ }
+return \$out;
+}
+
+
+
+1;
\ No newline at end of file
lifelog.hopto.org / LifeLog.git / commitdiff