From: Will Budic Date: Wed, 15 May 2024 22:37:05 +0000 (+1000) Subject: DATA instruction implementation as a table overhaul. X-Git-Url: https://lifelog.hopto.org/gitweb/?a=commitdiff_plain;h=bb67fb2e154fe1560eb98c0d2d41a248afd3692f;p=PerlCNF.git DATA instruction implementation as a table overhaul. --- diff --git a/system/modules/CNFParser copy.pm b/system/modules/CNFParser copy.pm deleted file mode 100644 index 3931754..0000000 --- a/system/modules/CNFParser copy.pm +++ /dev/null @@ -1,1432 +0,0 @@ -### -# Main Parser for the Configuration Network File Format. -## -package CNFParser; - -use strict;use warnings;#use warnings::unused; -use Exception::Class ('CNFParserException'); -use Syntax::Keyword::Try; -use Hash::Util qw(lock_hash unlock_hash); -use File::ReadBackwards; -use File::Copy; - -require CNFMeta; CNFMeta::import(); -require CNFNode; -require CNFDateTime; - -# 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 => '3.0'; -our @files; -our %lists; -our %properties; -our %instructors; -our $SQL; - -### -# Package fields are always global in perl! -### -our %ANONS; -#private -> Instance fields: - my $anons; - my @includes; my $CUR_SCRIPT; - my %instructs; - my $IS_IN_INCLUDE_MODE; - my $LOG_TRIM_SUB; -### -# CNF Instruction tag covered reserved words. -# You can't use any of these as your own possible instruction implementation, unless in lower case. -### - -our %RESERVED_WORDS = map +($_, 1), qw{ CONST CONSTANT DATA DATE VARIABLE VAR - FILE TABLE TREE INDEX - VIEW SQL MIGRATE DO LIB PROCESSOR - PLUGIN MACRO %LOG INCLUDE INSTRUCTOR }; - -sub isReservedWord { my ($self, $word)=@_; return $word ? $RESERVED_WORDS{$word} : undef } -### - -### -# Constance required setting, if set to 1, const method when called will rise exception rather then return undef. -### -our $CONSTREQ = 0; - -### -# Create a new CNFParser instance. -# $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) = @_; - if ($attrs){ - $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, 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 convienince bypass setting for code using it. - CNF_CONTENT => "", # Origin of the script, this will be set by the parser, usually the path of a script file or is direct content. - RUN_PROCESSORS => 1, # When enabled post parse processors are run, are these outside of the scope of the parsers executions. - }; - } - $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->{ENABLE_WARNINGS} = 1 if not exists $self->{ENABLE_WARNINGS}; - $self->{HAS_EXTENSIONS} = 0 if not exists $self->{HAS_EXTENSIONS}; - $self->{RUN_PROCESSORS} = 1 if not exists $self->{RUN_PROCESSORS}; #Bby default enabled, disable during script dev. - $self->{CNF_VERSION} = VERSION; - $self->{__DATA__} = {}; - undef $SQL; - bless $self, $class; $self->parse($path, undef, $del_keys) if($path); - return $self; -} -# - -sub import { - my $caller = caller; no strict "refs"; - { - *{"${caller}::configDumpENV"} = \&dumpENV; - *{"${caller}::anon"} = \&anon; - *{"${caller}::SQL"} = \&SQL; - *{"${caller}::isCNFTrue"} = \&_isTrue; - *{"${caller}::now"} = \&now; - } - return 1; -} - -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(); - - -### -# 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 -} -### -# Check a value if it is CNFPerl boolean true. -# For isFalse just negate check with not, as undef is concidered false or 0. -## -sub _isTrue{ - my $value = shift; - return 0 if(not $value); - return ($value =~ /1|true|yes|on/i) -} -### -# Post parsing instructed special item objects. They have lower priority to Order of apperance and from CNFNodes. -## -package InstructedDataItem { - - our $dataItemCounter = int(0); - - sub new { my ($class, $ele, $ins, $val) = @_; - 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 - }, $class - } - sub toString { - my $self = shift; - return "<<".$self->{ele}."<".$self->{ins}.">".$self->{val}.">>" - } -} -# - -### -# PropertyValueStyle objects must have same rule of how a property body can be scripted for attributes. -## -package PropertyValueStyle { - - sub new { - my ($class, $element, $script, $self) = @_; - $self = {} if not $self; - $self->{element}=$element; - if($script){ - my ($p,$v); - foreach my $itm($script=~/\s*(\w*)\s*[:=]\s*(.*)\s*/gm){ - if($itm){ - if(!$p){ - $p = $itm; - }else{ - $itm =~ s/^\s*(['"])(.*)\g{1}$/$2/g if $itm; - $self->{$p}=$itm; - undef $p; - } - } - } - }else{ - warn "PropertyValue process what?" - } - bless $self, $class - } - sub setPlugin{ - my ($self, $obj) = @_; - $self->{plugin} = $obj; - } - sub result { - my ($self, $value) = @_; - $self->{value} = $value; - } -} -# - -### -# 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) -# They can be; and are only dynamically set via the config instance directly. -# That is, if it has the ANONS_ARE_PUBLIC property set, and by using the empty method of anon() with no arguments. -# i.e. ${CNFParser->new()->anon()}{'MyDynamicAnon'} = 'something'; -# However a private config instance, will have its own anon's. And could be read only if it exist as a property, via this anon(NAME) method. -# This hasn't been yet fully specified in the PerlCNF specs. -# i.e. ${CNFParser->new({ANONS_ARE_PUBLIC=>0})->anon('MyDynamicAnon') # <-- Will not be available. -## -sub anon { my ($self, $n, $args)=@_; - my $anechoic = \%ANONS; - if(ref($self) ne 'CNFParser'){ - $n = $self; - }elsif (not $self->{'ANONS_ARE_PUBLIC'}){ - $anechoic = $self->{'__ANONS__'}; - } - if($n){ - my $ret = %$anechoic{$n}; - return if !$ret; - if($args){ - my $ref = ref($args); - if($ref eq 'META_PROCESS'){ - my @arr = ($ret =~ m/(\$\$\$.+?\$\$\$)/gm); - foreach my $find(@arr) {# <- MACRO TAG translate. -> - my $s= $find; $s =~ s/^\$\$\$|\$\$\$$//g;# - my $r = %$anechoic{$s}; - if(!$r && exists $self->{$s}){#fallback to maybe constant property has been seek'd? - $r = $self->{$s}; - } - if(!$r){ - warn "Unable to find property to translate macro expansion: $n -> $find\n" - unless $self and not $self->{ENABLE_WARNINGS} - }else{ - $ret =~ s/\Q$find\E/$r/g; - } - } - $ret = $args->process($n,$ret); - }elsif($ref eq 'HASHREF'){ - foreach my $key(keys %$args){ - if($ret =~ m/\$\$\$$key\$\$\$/g){ - my $val = %$args{$key}; - $ret =~ s/\$\$\$$key\$\$\$/$val/g; - } - } - }elsif($ref eq 'ARRAY'){ #we rather have argument passed as an proper array then a list with perl - my $cnt = 1; - foreach(@$args){ - $ret =~ s/\$\$\$$cnt\$\$\$/$_/g; - $cnt++; - } - }else{ - my $val = %$anechoic{$args}; - $ret =~ s/\$\$\$$args\$\$\$/$val/g; - warn "Scalar argument passed $args, did you mean array to pass? For property $n=$ret\n" - unless $self and not $self->{ENABLE_WARNINGS} - } - } - my $ref = ref($ret); - return $$ret if $ref eq "REF"; - return $ret->val() if $ref eq "CNFNode"; - return $ret; - } - return $anechoic; -} - -### -# Validates and returns a constant named value as part of this configs instance. -# 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; - return; -} - -### -# Collections are global, Reason for this is that any number of subsequent files parsed, -# might contain properties that overwrite previous existing ones. -# Or require ones that don't include, and expecting them to be there. -# This overwritting can be erronous, but also is not expected to be very common to happen. -# Following method, provides direct access to the properties, this method shouldn't be used in general. -sub collections {\%properties} - -#@Deprecated use property subroutine instead. -sub collection { -return property(@_); -} -### -# Collection now returns the contained type dereferenced and is concidered a property. -# Make sure you use the appropriate Perl type on the receiving end. -# Note, if properties contain any scalar key row, it sure hasn't been set by this parser. -# -sub property { my($self, $name) = @_; - if(exists($properties{$name})){ - my $ret = $properties{$name}; - my $ref = ref($ret); - if($ref eq 'ARRAY'){ - return @{$ret} - }elsif($ref eq 'PropertyValueStyle'){ - return $ret; - } - else{ - return %{$ret} - } - } - return %properties{$name} -} - -sub data {return shift->{'__DATA__'}} - -sub listDelimit { - my ($this, $d , $tag)=@_; - my @p = @{$lists{$tag}}; - if(@p&&$d){ - my @ret = (); - foreach (@p){ - my @s = split $d, $_; - push @ret, @s; - } - $lists{$tag}=\@ret; - return @{$lists{$tag}}; - } - return; -} -sub lists {\%lists} -sub list { - my $tag=shift;if(@_ > 0){$tag=shift;} - my $an = $lists{$tag}; - return @{$an} if defined $an; - die "Error: List name '$tag' not found!" -} - -# Adds a list of environment expected list of variables. -# This is optional and ideally to be called before parse. -# Requires and array of variables to be passed. -sub addENVList { my ($self, @vars) = @_; - if(@vars){ - foreach my $var(@vars){ - next if $self->{$var};##exists already. - if((index $var,0)=='$'){#then constant otherwise anon - $self->{$var} = $ENV{$var}; - } - else{ - anon()->{$var} = $ENV{$var}; - } - } - }return; -} - -### -# Perform a macro replacement on tagged strings in a property value. -## -sub template { my ($self, $property, %macros) = @_; - my $val = $self->anon($property); - if($val){ - foreach my $m(keys %macros){ - my $v = $macros{$m}; - $m ="\\\$\\\$\\\$".$m."\\\$\\\$\\\$"; - $val =~ s/$m/$v/gs; - } - my $prev; - foreach my $m(split(/\$\$\$/,$val)){ - if(!$prev){ - $prev = $m; - next; - } - undef $prev; - my $pv = $self->anon($m); - if(!$pv && exists $self->{$m}){ - $pv = $self->{$m}#constant($self, '$'.$m); - } - if($pv){ - $m = "\\\$\\\$\\\$".$m."\\\$\\\$\\\$"; - $val =~ s/$m/$pv/gs; - } - } - return $val; - } -} -# - -#private to parser sub. -sub doInstruction { my ($self,$e,$tag,$v) = @_; - my $DO_ENABLED = $self->{'DO_ENABLED'}; my $priority = 0; - $tag = "" if not defined $tag; - if($tag eq 'CONST' or $tag eq 'CONSTANT'){#Single constant with mulit-line value; - # It is NOT allowed to overwrite constant. - if (not $self->{$e}){ - $v =~ s/^\s//; - $self->{$e} = $v; - }else{ - warn "Skipped constant detected assignment for '$e'."; - } - } - elsif($tag eq 'VAR' or $tag eq 'VARIABLE'){ - $v =~ s/^\s//; - $anons->{$e} = $v; - } - elsif($tag eq 'DATA'){ - $self->doDataInstruction_($e,$v) - }elsif($tag eq 'DATE'){ - if($v && $v !~ /now|today/i){ - $v =~ s/^\s//; - if($self->{STRICT}&&$v!~/^\d\d\d\d-\d\d-\d\d/){ - $self-> warn("Invalid date format: $v expecting -> YYYY-MM-DD at start as possibility of DD-MM-YYYY or MM-DD-YYYY is ambiguous.") - } - $v = CNFDateTime::_toCNFDate($v,$self->{'TZ'}); - - }else{ - $v = CNFDateTime->new({TZ=>$self->{'TZ'}}); - } - $anons->{$e} = $v; - }elsif($tag eq 'FILE'){#@TODO Test case this - $self->doLoadDataFile($e,$v) if _isTrue($self->{AUTOLOAD_DATA_FILES}) - }elsif($tag eq 'INCLUDE'){ - if (!$v){ - $v=$e - }else{ - $anons = $v; - } - my $prc_last = ($v =~ s/($meta_process_last)/""/ei)?1:0; - if (includeContains($v)){ - $self->warn("Skipping adding include $e, path already is registered for inclusion -> $v"); - return; - } - $includes[@includes] = {script=>$v,local=>$CUR_SCRIPT,loaded=>0, prc_last=>$prc_last}; - }elsif($tag eq 'TREE'){ - 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; - }elsif($tag eq 'TABLE'){ # This has now be late bound and send to the CNFSQL package. since v.2.6 - $self->SQL()->createTable($e,$v) } # It is hardly been used. But in future this might change. - elsif($tag eq 'INDEX'){ $self->SQL()->createIndex($v)} - elsif($tag eq 'VIEW'){ SQL()->createView($e,$v)} - elsif($tag eq 'SQL'){ $self->SQL($e,$v)} - elsif($tag eq 'MIGRATE'){$self->SQL()->migrate($e, $v) - } - elsif($tag eq 'DO'){ - if($DO_ENABLED){ - my $ret; - if (!$v){ - $v = $e; - $e = 'LAST_DO'; - } - 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 - $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($tag 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($tag eq 'PLUGIN'){ - if($DO_ENABLED){ - $instructs{$e} = InstructedDataItem -> new($e, 'PLUGIN', $v); - }else{ - $self->warn("DO_ENABLED is set to false to process following plugin: $e\n") - } - } - elsif($tag eq 'PROCESSOR'){ - if(not $self->registerProcessor($e, $v)){ - CNFParserException->throw("PostParseProcessor Registration Failed for '<<$e<$tag>$v>>'!\t"); - } - } - elsif($tag eq 'INSTRUCTOR'){ - if(not $self->registerInstructor($e, $v) && $self->{STRICT}){ - CNFParserException->throw("Instruction Registration Failed for '<<$e<$tag>$v>>'!\t"); - } - } - elsif($tag eq 'MACRO'){ - $instructs{$e}=$v; - } - elsif(exists $instructors{$tag}){ - if(not $instructors{$tag}->instruct($e, $v) && $self->{STRICT}){ - CNFParserException->throw("Instruction processing failed for '<<$e<$tag>>'!\t"); - } - } - 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. - if($self->{'HAS_EXTENSIONS'}){ - $anons->{$e} = InstructedDataItem->new($e,$tag,$v) - }else{ - $v = $tag if not $v; - if($e=~/^\$/){ - $self->{$e} = $v if !$self->{$e}; # Not allowed to overwrite constant. - }else{ - $anons->{$e} = $v - } - } - } - else{ - $e = substr $e, 0, (rindex $e, '$$'); - # Following is confusing as hell. We look to store in the hash an array reference. - # But must convert back and fort via an scalar, since actual arrays returned from an hash are references in perl. - my $array = $lists{$e}; - if(!$array){$array=();$lists{$e} = \@{$array};} - push @{$array}, $v; - } - } -} -sub doLoadDataFile { my ($self,$e,$v)=@_; - my ($i,$path,$cnf_file) = (0,"",$self->{CNF_CONTENT}); - $v=~s/\s+//g; - $path = substr($path, 0, rindex($cnf_file,'/')) .'/'.$v; - foreach(@files){ - return if $_ eq $path - } - # - open(my $fh, "<:perlio", $path ) or CNFParserException->throw("Can't open $path -> $!"); - read $fh, my $content, -s $fh; - close $fh; - # - push @files, $path; - my @tags = ($content =~ m/<<(\w*<(.*?).*?>>)/gs); - foreach my $tag (@tags){ - next if not $tag; - my @kv = split />"); - } - else{ - $v = substr $tag, $i+1, (rindex $tag, ">>")-($i+1); - $tag = substr $tag, 0, $i; - } - if($tag eq 'DATA'){ - $self->doDataInstruction_($e,$v) - } - } -} -#private -sub doDataInstruction_{ my ($self,$e,$v,$t,$d)=@_; - my $add_as_SQLTable = $v =~ s/${meta('SQL_TABLE')}/""/sexi; - $v=~ s/^\s*//gm; - foreach my $row(split(/~\s/,$v)){ - my @a; - $row =~ s/\\`/\\f/g;#We escape to form feed the found 'escaped' backtick so can be used as text. - my @cols = $row =~ m/([^`]*)`{0,1}/gm;pop @cols;#<-regexp is special must pop last empty element. - foreach my $d(@cols){ - $d =~ s/\\f/`/g; #escape back form feed to backtick. - $d =~ s/^\s*|~$//g; #strip dangling ~ if there was no \n - $t = substr $d, 0, 1; - if($t eq '$'){ - $v = $d; #capture specked value. - $d =~ s/\$$|\s*$//g; #trim any space and system or constant '$' end marker. - if($v=~m/\$$/){ - $v = $self->{$d}; - } - else{ - $v = $d; - } - $v="" if not $v; - push @a, $v; - } - else{ - if($d =~ /^\#(.*)/) {#First is usually ID a number and also '#' signifies number. - $d = $1; - $d=0 if !$d; #default to 0 if not specified. - push @a, $d - } - else{ - $d="" if not $d; - push @a, $d; - } - } - } - if($add_as_SQLTable){ - my ($INT,$BOOL,$TEXT,$DATE) = (meta('INT'),meta('BOOL'),meta('TEXT'),meta('DATE')); - my $ret = CNFMeta::_metaTranslateDataHeader(@a); - @a = @{@$ret[0]}; - $self->SQL()->createTable($e,${@{$ret}[1]}); - $add_as_SQLTable = 0; - } - - my $existing = $self->{'__DATA__'}{$e}; - if(defined $existing){ - my @rows = @$existing; - push @rows, [@a] if scalar @a >0; - $self->{'__DATA__'}{$e} = \@rows - }else{ - my @rows; push @rows, [@a]; - $self->{'__DATA__'}{$e} = \@rows if scalar @a >0; - } - } -} - -### -# Parses a CNF file or a text content if specified, for this configuration object. -## -sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; - - my @tags; - if($self->{'ANONS_ARE_PUBLIC'}){ - $anons = \%ANONS; - }else{ - $anons = $self->{'__ANONS__'}; - } - - # 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_file ) or die "Can't open $cnf_file -> $!"; - read $fh, $content, -s $fh; - close $fh; - my @stat = stat($cnf_file); - $self->{CNF_STAT} = \@stat; - $self->{CNF_CONTENT} = $CUR_SCRIPT = $cnf_file; - }else{ - my $type = Scalar::Util::reftype($content); - if($type && $type eq 'ARRAY'){ - $content = join "",@$content; - $self->{CNF_CONTENT} = 'ARRAY'; - }else{ - $CUR_SCRIPT = \$content; - $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}; - - - my $spc = $content =~ /\n/ ? '(<{2,3}?)(<*.*?>*)(>{2,3})' : '(<{2,3}?)(<*.*?>*?)(>{2,3})$'; - @tags = ($content =~ m/$spc/gms); - - foreach my $tag (@tags){ - next if not $tag; - next if $tag =~ m/^(>+)|^(<<)/; - if($tag =~ m/^<(\w*)\s+(.*?)>*$/gs){ # Original fastest and early format: <<>> - my $tag = $1; - my $v = $2; - if(isReservedWord($self,$tag)){ - my $isVar = ($tag eq 'VARIABLE' || $tag eq 'VAR'); - if($tag 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/;#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." - } - } - } - } - }else{ - doInstruction($self,$v,$tag,undef); - } - }else{ - $v =~ s/\s*>$//; - $anons->{$tag} = $v; - } - - }else{ - #vars are e-element,t-token or instruction,v- for value, vv -array of the lot. - my ($e,$tag,$v,@vv); - - # Check if very old format and don't parse the data for old code compatibility to (still) do it. - # This is interesting, as a newer format file is expected to use the DATA instruction and final data specified script rules. - if($CNF_VER eq 'CNF2.2' && $tag =~ m/(\w+)\s*(<\d+>\s)\s*(.*\n)/mg){#It is old DATA format annon - $e = $1; - $tag = $2; - $v = substr($tag,length($e)+length($tag)); - $anons->{$e} = $v; - next; - } - # Before mauling into possible value types, let us go for the full expected tag specs first: - # <<{$sig}{name}<{INSTRUCTION}>{value\n...value\n}>> - # Found in -> - if($tag !~ /\n/ && $tag =~ /^([@%\$\.\/\w]+)\s*([ <>]+)(\w*>)(.*)/) { - $e = $1; - $tag = $2; - if($tag =~ /^<\s*$// if $tag ne '<<' && $tag =~ />$/ - }else{ - $tag =~ m/([@%\$\.\/\w]+) ([ <>\n|^\\]{1})+ ([^<^>^^\n]+) ([<>]?) (.*)/gmxs; - $tag = $3; - $v = $5; - } - }else{ - ############################################################################# - $tag =~ m/\s*([@%\$\.\/\w]+)\s* # The name. - ([ <>\n]) # begin or close of instruction, where '\n' mark in script as instruction less. - ([^<^>^^\n]+) # instruction or value of anything - ([<>\n]?) # close mark for instuction or is less if \n encountered before. - (.*) # actual value is the rest. - (>$)* # capture above value up to here from buffer, i.e. if comming from a >>> tag. - /gmxs; ############################################################################### - - $e =$1; - if($e eq '@' or $2 eq '<' or ($2 eq '>' and !$4)){ - $tag = $3; - }else{ - $tag = $1; - $e = $3 - } - $v= $5; - $v =~ s/>$//m if defined($4) && $4 eq '<' or $6; #value has been crammed into an instruction? - - } - if(!$v && !$RESERVED_WORDS{$tag}){ - $v= $tag; - } - $v =~ s/\\/>/g;# escaped brackets from v.2.8. - - #Do we have an autonumbered instructed list? - #DATA best instructions are exempted and differently handled by existing to only one uniquely named property. - #So its name can't be autonumbered. - if ($e =~ /(.*?)\$\$$/){ - $e = $1; - if($tag && $tag ne 'DATA'){ - my $array = $lists{$e}; - if(!$array){$array=();$lists{$e} = \@{$array};} - push @{$array}, InstructedDataItem -> new($e, $tag, $v); - next - } - }elsif ($e eq '@'){#collection processing. - my $isArray = $tag=~ m/^@/; - # if(!$v && $tag =~ m/(.*)>(\s*.*\s*)/gms){ - # $tag = $1; - # $v = $2; - # } - my @lst = ($isArray?split(/[,\n]/, $v):split('\n', $v)); $_=""; - my @props = map { - s/^\s+|\s+$//; # strip unwanted spaces - s/^\s*["']|['"]$//g;#strip quotes - #s/>+//;# strip dangling CNF tag - $_ ? $_ : undef # return the modified string - } @lst; - if($isArray){ - if($self->isReservedWord($tag)){ - $self->warn("ERROR collection is trying to use a reserved property name -> $tag."); - next - }else{ - my @arr=(); - foreach (@props){ - push @arr, $_ if($_ && length($_)>0); - } - $properties{$tag}=\@arr; - } - }else{ - my %hsh; - my $macro = 0; - if(exists($properties{$tag})){ - if($self->isReservedWord($tag)){ - $self->warn("Skipped overwritting reserved property -> $tag."); - next - }else{ - %hsh = %{$properties{$tag}} - } - }else{ - %hsh =(); - } - foreach my $p(@props){ - if($p && $p eq 'MACRO'){$macro=1} - elsif( $p && length($p)>0 ){ - my @pair = ($p=~/\s*([-+_\w]*)\s*[=:]\s*(.*)/s);#split(/\s*=\s*/, $p); - 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($macro){ - my @arr = ($value =~ m/(\$\$\$.+?\$\$\$)/gm); - foreach my $find(@arr) { - my $s = $find; $s =~ s/^\$\$\$|\$\$\$$//g; - my $r = $anons->{$s}; - $r = $self->{$s} if !$r; - $r = $instructs{$s} if !$r; - CNFParserException->throw(error=>"Unable to find property for $tag.$name -> $find\n",show_trace=>1) if !$r; - $value =~ s/\Q$find\E/$r/g; - } - } - $hsh{$name}=$value; $self->log("macro $tag.$name->$value\n") if $self->{DEBUG} - } - } - $properties{$tag}=\%hsh; - } - next; - } - doInstruction($self,$e,$tag,$v) - } - } - # Do scripted includes first. As these might set properties imported and processed used by the main script. - if(@includes){ - $includes[@includes] = {script=>$CUR_SCRIPT,loaded=>1, prc_last=>0} if not includeContains($CUR_SCRIPT); #<- to prevent circular includes. - foreach (@includes){ - $self -> doInclude($_) if $_ && not $_->{prc_last} and not $_->{loaded} and $_->{local} eq $CUR_SCRIPT; - } - } - ### Do the smart instructions and property linking. - if(%instructs && not $IS_IN_INCLUDE_MODE){ - my @items; - foreach my $e(keys %instructs){ - my $struct = $instructs{$e}; - my $type = ref($struct); - if($type eq 'String'){ - my $v = $struct; - my @arr = ($v =~ m/(\$\$\$.+?\$\$\$)/gm); - foreach my $find(@arr) {# <- MACRO TAG translate. -> - my $s= $find; $s =~ s/^\$\$\$|\$\$\$$//g;# - my $r = %$anons{$s}; - $r = $self->{$s} if !$r; - if(!$r){ - $self->warn("Unable to find property to translate macro expansion: $e -> $find\n"); - }else{ - $v =~ s/\Q$find\E/$r/g; - } - } - $anons->{$e}=$v; - }else{ - $items[@items] = $struct; - } - } - - @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-> priority() > 0){ - $struct->validate() if $self->{ENABLE_WARNINGS}; - $anons ->{$struct->name()} = $struct->process($self, $struct->script()); - splice @items, $idx, 1 - } - } - #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()); - }elsif($type eq 'InstructedDataItem'){ - my $tag = $struct->{ins}; - if($tag eq 'PLUGIN'){ - instructPlugin($self,$struct,$anons); - } - }else{warn "What is -> $struct type:$type ?"} - } - undef %instructs; - } - - foreach (@includes){ - $self -> doInclude($_) if $_ && (not $_->{loaded} and $_->{local} eq $CUR_SCRIPT) - } - undef @includes if not $IS_IN_INCLUDE_MODE; - - foreach my $k(@$del_keys){ - delete $self->{$k} if exists $self->{$k} - } - my $runProcessors = $self->{RUN_PROCESSORS} ? 1: 0; - lock_hash(%$self);#Make repository finally immutable. - runPostParseProcessors($self) if $runProcessors; - if ($LOG_TRIM_SUB){ - $LOG_TRIM_SUB->(); - undef $LOG_TRIM_SUB; - } - return $self -} -# - sub includeContains{ - my $path = shift; - foreach(@includes){ - return 1 if $_&&$_->{script} eq $path - } - return 0 - } -### -# Loads and parses includes local to script. -### -sub doInclude { my ($self, $prp_file) = @_; - if(!$prp_file->{loaded}){ - my $file = $prp_file->{script}; - if(!-e $file){$file =~ m/.*\/(.*$)/; $file = $1} - if(open(my $fh, "<:perlio", $file)){ - read $fh, my $content, -s $fh; - close $fh; - if($content){ - my $cur_script = $CUR_SCRIPT; - $prp_file->{loaded} = 1; - $CUR_SCRIPT = $prp_file->{script}; - # Perl is not OOP so instructions are gathered into one place, time will tell if this is desirable rather then a curse. - # As per file processing of instructions is not encapsulated within a included file, but main includer or startup script. - $IS_IN_INCLUDE_MODE = 1; - $self->parse(undef, $content); - $IS_IN_INCLUDE_MODE = 0; - $CUR_SCRIPT = $cur_script; - }else{ - $self->error("Include content is blank for include -> ".$prp_file->{script}) - } - }else{ - $prp_file->{loaded} = 0; - $self->error("Script include not available for include -> ".$prp_file->{script}); - CNFParserException->throw("Can't open include ".$prp_file->{script}." -> $!") if $self->{STRICT}; - } - } -} - -sub instructPlugin { - my ($self, $struct, $anons) = @_; - try{ - $properties{$struct->{'ele'}} = doPlugin($self, $struct, $anons); - $self->log("Plugin instructed ->". $struct->{'ele'}); - }catch($e){ - if($self->{STRICT}){ - CNFParserException->throw(error=>$e); - }else{ - $self->trace("Error @ Plugin -> ". $struct->toString() ." Error-> $@") - } - } -} -# - -### -# Register Instructor on tag and value for to be externally processed. -# $package - Is the anonymouse package name. -# $body - Contains attribute(s) linking to method(s) to be registered. -# @TODO Current Under development. -### -sub registerInstructor { - my ($self, $package, $body) = @_; - $body =~ s/^\s*|\s*$//g; - my ($obj, %args, $ins, $mth); - foreach my $ln(split(/\n/,$body)){ - my @pair = $ln =~ /\s*(\w+)[:=](.*)\s*/; - $ins = $1; $ins = $ln if !$ins; - $mth = $2; - if($ins =~ /[a-z]/i){ - $args{$ins} = $mth; - } - } - if(exists $instructors{$ins}){ - $self -> error("$package<$ins> <- Instruction has been previously registered by: ".ref(${$instructors{$ins}})); - return; - }else{ - - foreach(values %instructors){ - if(ref($$_) eq $package){ - $obj = $_; last - } - } - - if(!$obj){ - ## no critic (RequireBarewordIncludes) - require $package.'.pm'; - my $methods = Class::Inspector->methods($package, 'full', 'public'); - my ($has_new,$has_instruct); - foreach(@$methods){ - $has_new = 1 if $_ eq "$package\::new"; - $has_instruct = 1 if $_ eq "$package\::instruct"; - } - if(!$has_new){ - $self -> log("ERR $package<$ins> -> new() method not found for package."); - return; - } - if(!$has_instruct){ - $self -> log("ERR $package<$ins> -> instruct() required method not found for package."); - return; - } - $obj = $package -> new(\%args); - } - $instructors{$ins} = \$obj - } - return \$obj; -} -# - -### -# Register PostParseProcessor for further externally processing. -# $package - Is the anonymouse package name. -# $body - Contains attribute(s) where function is the most required one. -### -sub registerProcessor { - my ($self, $package, $body) = @_; - $body =~ s/^\s*|\s*$//g if $body; - my ($obj, %args, $ins, $mth, $func); - foreach my $ln(split(/\n/,$body)){ - my @pair = $ln =~ /\s*(\w+)[:=](.*)\s*/; - $ins = $1; $ins = $ln if !$ins; - $mth = $2; - if($ins =~ /^func\w*/){ - $func = $mth - } - elsif($ins =~ /[a-z]/i){ - $args{$ins} = $mth - } - } - $func = $ins if !$func; - if(!$func){ - $self -> log("ERR <<$package<$body>> function attribute not found set."); - return; - } - ## no critic (RequireBarewordIncludes) - require $package.'.pm'; - my $methods = Class::Inspector->methods($package, 'full', 'public'); - my ($has_new,$has_func); - foreach(@$methods){ - $has_new = 1 if $_ eq "$package\::new"; - $has_func = 1 if $_ eq "$package\::$func"; - } - if(!$has_new){ - $self -> log("ERR In package $package -> new() method not found for package."); - return; - } - if(!$has_func){ - $self -> log("ERR In package $package -> $func(\$parser) required method not found for package."); - return; - } - $obj = $package -> new(\%args); - $self->addPostParseProcessor($obj,$func); - return 1; -} - -sub addPostParseProcessor { - my $self = shift; - my $processor = shift; - my $func = shift; - my @arr; - my $arf = $self->{POSTParseProcessors} if exists $self->{POSTParseProcessors}; - @arr = @$arf if $arf; - $arr[@arr] = [$processor, $func]; - $self->{POSTParseProcessors} = \@arr; -} - -sub runPostParseProcessors { - my $self = shift; - my $arr = $self->{POSTParseProcessors} if exists $self->{POSTParseProcessors}; - foreach(@$arr){ - my @objdts =@$_; - my $prc = $objdts[0]; - my $func = $objdts[1]; - $prc -> $func($self); - } -} - -# - -### -# Setup and pass to pluging CNF functionality. -# @TODO Current Under development. -### -sub doPlugin { - my ($self, $struct, $anons) = @_; - my ($elem, $script) = ($struct->{'ele'}, $struct->{'val'}); - my $plugin = PropertyValueStyle->new($elem, $script); - my $pck = $plugin->{package}; - my $prp = $plugin->{property}; - my $sub = $plugin->{subroutine}; - if($pck && $prp && $sub){ - ## no critic (RequireBarewordIncludes) - require "$pck.pm"; - #Properties are global, all plugins share a %Settings property if specifed, otherwise the default will be set from here only. - my $settings = $properties{'%Settings'}; - if($settings){ - foreach(keys %$settings){ - #We allow for now, the plugin have settings set by its property, do not overwrite if exists as set. - $plugin->{$_} = $settings->{$_} unless exists $plugin->{$_} - } ; - } - my $obj = $pck->new($plugin); - my $res = $obj-> $sub($self, $prp); - if($res){ - $plugin->setPlugin($obj); - return $plugin; - }else{ - die "Sorry, the PLUGIN feature has not been Implemented Yet!" - } - } - else{ - die qq(Invalid plugin encountered '$elem' in "). $self->{'CNF_CONTENT'} .qq( - Plugin must have attributes -> 'package', 'property' and 'subroutine') - } -} - -### -# Generic CNF Link utility on this repository. -## -sub obtainLink { - my ($self,$link, $ret) = @_; - my $meths; - ## no critic BuiltinFunctions::ProhibitStringyEval - no strict 'refs'; - if($link =~/(\w*)::\w+$/){ - use Module::Loaded qw(is_loaded); - if(is_loaded($1)){ - $ret = \&{+$link}($self); - }else{ - eval require "$1.pm"; - $ret = &{+$link}; - if(!$ret){ - $self->error( qq(Package constance link -> $link is not available (try to place in main:: package with -> 'use $1;'))); - $ret = $link - } - } - }else{ - $ret = $self->anon($link); - $ret = $self-> {$link} if !$ret; - } - return $ret; -} - -### -# 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) = @_; - my $buffer; - if(!$property){ - my @keys = sort keys %$self; - $buffer = "<< $with - } - foreach my $key(@keys){ - my $spc = $with - length($key); - my $val = $self->{$key}; - next if(ref($val) =~ /ARRAY|HASH/); #we write out only what is scriptable. - if(!$val){ - if($key =~ /^is|^use|^bln|enabled$/i){ - $val = 0 - }else{ - $val = "\"\"" - } - } - elsif #Future versions of CNF will account also for multiline values for property attributes. - ($val =~ /\n/){ - $val = "<#<\n$val>#>" - } - elsif($val !~ /^\d+/){ - $val = "\"$val\"" - } - $buffer .= ' 'x$spc. $key . " = $val\n"; - } - $buffer .= ">>"; - return $buffer if !$handle; - print $handle $buffer; - return 1 - } - my $prp = $properties{$property}; - if($prp){ - $buffer = "<<@<$property>\n"; - if(ref $prp eq 'ARRAY') { - my @arr = sort keys @$prp; my $n=0; - foreach (@arr){ - $buffer .= "\"$_\""; - if($arr[-1] ne $_){ - if($n++>5){ - $buffer .= "\n"; $n=0 - }else{ - $buffer .= "," - } - } - } - }elsif(ref $prp eq 'HASH') { - my %hsh = %$prp; - my @keys = sort keys %hsh; - foreach my $key(@keys){ - $buffer .= $key . "\t= \"". $hsh{$key} ."\"\n"; - } - } - $buffer .= ">>\n"; - return $buffer if !$handle; - print $handle $buffer; - return 1; - } - else{ - $prp = $ANONS{$property}; - $prp = $self->{$property} if !$prp; - if (!$prp){ - $buffer = "<Property not found!>>>\n" - }else{ - $buffer = "<<$property><$prp>>\n"; - } - return $buffer if !$handle; - print $handle $buffer; - return 0; - } -} - -### -# The following is a typical example of an log settings property. -# -# <<@<%LOG> -# file = web_server.log -# # Should it mirror to console too? -# console = 1 -# # Disable/enable output to file at all? -# enabled = 0 -# # Tail size cut, set to 0 if no tail cutting is desired. -# tail = 1000 -# >> -### -sub log { - my $self = shift; - my $message = shift; - my $type = shift; $type = "" if !$type; - my $isWarning = $type eq 'WARNG'; - my $attach = join @_; $message .= $attach if $attach; - my %log = $self -> property('%LOG'); - my $time = exists $self->{'TZ'} ? CNFDateTime -> new(TZ=>$self->{'TZ'}) -> toTimestamp() : - CNFDateTime -> new()-> toTimestamp(); - - $message = "$type $message" if $isWarning; - - if($message =~ /^ERROR/ || $isWarning){ - warn $time . " " .$message; - } - elsif(%log && $log{console}){ - print $time . " " .$message ."\n" - } - if(%log && _isTrue($log{enabled}) && $message){ - my $logfile = $log{file}; - my $tail_cnt = $log{tail}; - if($logfile){ - open (my $fh, ">>", $logfile) or die $!; - print $fh $time . " - " . $message ."\n"; - close $fh; - if($tail_cnt>0 && !$LOG_TRIM_SUB){ - $fh = File::ReadBackwards->new($logfile) or die $!; - if($fh->{lines}>$tail_cnt){ - $LOG_TRIM_SUB = sub { - my $fh = File::ReadBackwards->new($logfile) or die $!; - my @buffer; $buffer[@buffer] = $fh->readline() for (1..$tail_cnt); - open (my $fhTemp, ">", "/tmp/$logfile") or die $!; - print $fhTemp $_ foreach (reverse @buffer); - close $fhTemp; - move("/tmp/$logfile",$logfile) - } - } - } - } - } - return $time . " " .$message; -} -sub error { - my $self = shift; - my $message = shift; - $self->log("ERROR $message"); -} -use Carp qw(cluck); #what the? I know... -sub warn { - my $self = shift; - my $message = shift; - if($self->{ENABLE_WARNINGS}){ - $self -> log($message,'WARNG'); - } -} -sub trace { - my $self = shift; - my $message = shift; - my %log = $self -> property('%LOG'); - if(%log){ - $self -> log($message) - }else{ - cluck $message - } -} - -sub now {return CNFDateTime->new(shift)} - -sub dumpENV{ - foreach (keys(%ENV)){print $_,"=", "\'".$ENV{$_}."\'", "\n"} -} - -sub SQL { - if(!$SQL){##It is late compiled package on demand. - my $self = shift; - my $data = shift; - require CNFSQL; $SQL = CNFSQL->new({parser=>$self}); - } - $SQL->addStatement(@_) if @_; - return $SQL; -} -our $JSON; -sub JSON { - my $self = shift; - if(!$JSON){ - require CNFJSON; - $JSON = CNFJSON-> new({ CNF_VERSION => $self->{CNF_VERSION}, - CNF_CONTENT => $self->{CNF_CONTENT}, - DO_ENABLED => $self->{DO_ENABLED} - }); - } - return $JSON; -} - -### -# CNFNodes are kept as anons by the TREE instruction, but these either could have been futher processed or -# externaly assigned too as nodes to the parser. -### -our %NODES; -sub addTree { - my ($self, $name, $node )= @_; - if($name && $node){ - $NODES{$name} = $node; - } -} -### Utility way to obtain CNFNodes from a configuration. -sub getTree { - my ($self, $name) = @_; - return $NODES{$name} if exists $NODES{$name}; - my $ret = $self->anon($name); - if(ref($ret) eq 'CNFNode'){ - return \$ret; - } - return; -} - -sub END { -$LOG_TRIM_SUB->() if $LOG_TRIM_SUB; -undef %ANONS; -undef @files; -undef %properties; -undef %lists; -undef %instructors; -} -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 - -__END__ -## Instructions & Reserved words - - 1. Reserved words relate to instructions, that are specially treated, and interpreted by the parser to perform extra or specifically processing on the current value. - 2. Reserved instructions can't be used for future custom ones, and also not recommended tag or property names. - 3. Current Reserved words list is. - - CONST - Concentrated list of constances, or individaly tagged name and its value. - - VARIABLE - Concentrated list of anons, or individaly tagged name and its value. - - DATA - CNF scripted delimited data property, having uniform table data rows. - - DATE - Translate PerlCNF date representation to DateTime object. Returns now() on empty property value. - - FILE - CNF scripted delimited data property is in a separate file. - - %LOG - Log settings property, i.e. enabled=>1, console=>1. - - TABLE - SQL related. - - TREE - Property is a CNFNode tree containing multiple debth nested children nodes. - - INCLUDE - Include properties from another file to this repository. - - INDEX - SQL related. - - INSTRUCT - Provides custom new anonymous instruction. - - VIEW - SQL related. - - PLUGIN - Provides property type extension for the PerlCNF repository. - - PROCESSOR- Registered processor to be called once all parsing is done and repository secured. - - SQL - SQL related. - - MIGRATE - SQL related. - - MACRO - 1. Value is searched and replaced by a property value, outside the property scripted. - 2. Parsing abruptly stops if this abstract property specified is not found. - 3. Macro format specifications, have been aforementioned in this document. However make sure that your macro an constant also including the *$* signifier if desired. \ No newline at end of file diff --git a/system/modules/CNFParser.pm b/system/modules/CNFParser.pm index 69f766d..49a97a7 100644 --- a/system/modules/CNFParser.pm +++ b/system/modules/CNFParser.pm @@ -92,7 +92,7 @@ sub new { my ($class, $path, $attrs, $del_keys, $self) = @_; $self->{RUN_PROCESSORS} = 1 if not exists $self->{RUN_PROCESSORS}; #By default enabled, disable during script dev. # Autoload the data type properties placed in a separate file, from a FILE instruction. $self->{AUTOLOAD_DATA_FILES} =1 if not exists $self->{AUTOLOAD_DATA_FILES}; - $self->{CNF_VERSION} = VERSION; + $self->{CNF_VERSION} = VERSION; #Get's overwritten via parsing. $self->{__DATA__} = {}; undef $SQL; bless $self, $class; $self -> parse($path, undef, $del_keys) if($path); @@ -155,7 +155,7 @@ __JSON sub _isTrue{ my $value = shift; return 0 if(not $value); - return ($value =~ /1|true|yes|on|t|da/i) + return ($value =~ /1|true|yes|on|t|da/i) ? 1:0 } ### @@ -635,11 +635,24 @@ sub loadDataFile { my ($self,$e,$path,$v,$i)=@_; } } } +## +# DATA instructions are not preserved as CNF script values as would be redundand and a waist. +# They by default are only META translated into tables for efficiancy by data property name. #private sub doDataInstruction_{ my ($self,$e,$v,$t,$d)=@_; my $add_as_SQLTable = $v =~ s/${meta('SQL_TABLE')}/""/sexi; my $isPostgreSQL = $v =~ s/${meta('SQL_PostgreSQL')}/""/sexi; - my $isHeader = 0; + my $isAutonumber = $v =~ s/${meta('AUTO_NUMBERED')}|${meta('AUTONUMBER')}/""/sexi; + my $isHeader = $v =~ s/${meta('HAS_HEADER')}/""/sexi; + $isHeader = 1 if !$isHeader && ($isAutonumber||$add_as_SQLTable||$isPostgreSQL); + my @hdr; my @rows; my $autonumber = 0; + my $ref = $self->{__DATA__}{$e}; + if($ref){ + $ref = $$ref; + @hdr = @{$ref->{header}}; + @rows= @{$ref->{data}}; + $autonumber = $ref->{auto}; $isAutonumber = 1 if($autonumber || $isAutonumber); + } $v=~ s/^\s*//gm; foreach my $row(split(/~\s/,$v)){ my @a; @@ -653,10 +666,10 @@ sub doDataInstruction_{ my ($self,$e,$v,$t,$d)=@_; $v = $d; #capture specked value. $d =~ s/\$$|\s*$//g; #trim any space and system or constant '$' end marker. if($v=~m/\$$/){ - $v = $self->{$d}; + $v = $self->{$d}; } else{ - $v = $d; + $v = $d; } $v="" if not $v; push @a, $v; @@ -664,35 +677,32 @@ sub doDataInstruction_{ my ($self,$e,$v,$t,$d)=@_; else{ if($d =~ /^\#(.*)/) {#First is usually ID a number and also '#' signifies number. $d = $1; - $d=0 if !$d; #default to 0 if not specified. - push @a, $d + if(!$d){ + if($isAutonumber){ $d= ++$autonumber }else{$d=0} + } } else{ - $d="" if not $d; - push @a, $d; + $d="" if $d ne '0' && not $d; } + push @a, $d; } } - if($add_as_SQLTable){ - my ($INT,$BOOL,$TEXT,$DATE) = (meta('INT'),meta('BOOL'),meta('TEXT'),meta('DATE')); - my $ret = CNFMeta::_metaTranslateDataHeader($isPostgreSQL,@a); - my @hdr = @$ret; - @a = @{$hdr[0]}; - $self->SQL()->createTable($e,${$hdr[1]},$hdr[2]); - $add_as_SQLTable = 0;$isHeader=1; - } - my $existing = $self->{'__DATA__'}{$e}; - if(defined $existing){ - if($isHeader){$isHeader=0;next} - my @rows = @$existing; - push @rows, [@a] if scalar @a >0; - $self->{'__DATA__'}{$e} = \@rows - }else{ - my @rows; push @rows, [@a]; - $self->{'__DATA__'}{$e} = \@rows if scalar @a >0; + if(!@hdr && $isHeader){ + my $ptr = CNFMeta::_metaTranslateDataHeader($isPostgreSQL,@a); + @hdr = @{$$ptr}; $isHeader = 0; + $self->SQL()->createTable($e,${$hdr[1]},$hdr[2]) if$add_as_SQLTable + }elsif(scalar @a > 0){ + if($isHeader){ + $isHeader = 0; + }else{ + push @rows, [@a] + } } } + my $ret = {name=>$e,header=>\@hdr,data=>\@rows,auto=>$autonumber}; + $self->{__DATA__}{$e} = \$ret + } ### @@ -727,10 +737,14 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; $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}; - + $content =~ m/^\!(CNF(\d+\.\d+))/; + my $CNF_VER = $1; + if (not $CNF_VER){ + $CNF_VER="Undefined!" + }elsif(VERSION()<$2){ + $self->warn("CNF Script version is newer, are you using the latest parser version $CNF_VER?"); + } + $self->{CNF_VERSION} = $CNF_VER; my $spc = $content =~ /\n/ ? '(<{2,3}?)(<*.*?>*)(>{2,3})' : '(<{2,3}?)(<*.*?>*?)(>{2,3})$'; @tags = ($content =~ m/$spc/gms); @@ -744,8 +758,8 @@ 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) { - my $isMETAConst = $line =~ s/$meta_const//se; + foreach my $line (split '\n', $v) { + my $isMETAConst = $line =~ s/$meta_const//s; $line =~ s/^\s+|\s+$//; # strip unwanted spaces $line =~ s/\s*>$//; $line =~ m/([\$\w]*)(\s*=\s*)(.*)/g; @@ -753,7 +767,7 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; $line = $3; $line =~ s/^\s*(['"])(.*)\g{1}$/$2/ if $line;#strip quotes if(defined $name){ if($isVar && not $isMETAConst){ - $anons ->{$name} = $line if $line + $anons ->{$name} = $line if $line }else{ $name =~ s/^\$// if $isMETAConst; # It is NOT allowed to overwrite a constant, so check an issue warning. @@ -1047,7 +1061,7 @@ sub instructPlugin { my ($self, $struct) = @_; try{ $properties{$struct->{'ele'}} = doPlugin($self, $struct); - $self->log("Plugin instructed ->". $struct->{'ele'}); + $self->log("CNFParser plugin instructed -> ". $struct->{'ele'}); }catch($e){ if($self->{STRICT}){ CNFParserException->throw(error=>$e); @@ -1222,7 +1236,7 @@ sub doPlugin { $plugin->{instructor} = $instructor; return $plugin; }else{ - die "Sorry, the PLUGIN feature has not been Implemented Yet!" + die "Sorry, the PLUGIN in <<".$plugin->{element}.">> feature has failed or not been fully implemented yet!" } } else{ diff --git a/system/modules/CNFSQL.pm b/system/modules/CNFSQL.pm index e58aa91..799d78f 100644 --- a/system/modules/CNFSQL.pm +++ b/system/modules/CNFSQL.pm @@ -179,8 +179,6 @@ try{ $qinto =~ s/,$//; $q =~ s/,$//; $ins = $db -> prepare("INSERT INTO $tbl ($qinto)\nVALUES ($q);"); - - my $data = $self->{parser} -> {'__DATA__'}; if($data){ my $data_prp = %$data{$t}; @@ -189,16 +187,19 @@ try{ } if($data_prp){ my @hdr; - my @rows = @$data_prp; + my @header = CNFMeta::_deRefArray($$data_prp->{header}); @header = CNFMeta::_deRefArray($header[0]); + my @rows = CNFMeta::_deRefArray($$data_prp->{data}); my $auto_increment=0; + for my $i(0 .. $#header){ + $hdr[@hdr]={'_'=>$header[$i],'i'=>$i} + } + $self->{parser} ->error("Header not set for table -> $t") if ! @hdr; + $db->begin_work(); + for my $row_idx (0 .. $#rows){ my @col = @{$rows[$row_idx]}; - if($row_idx==0){ - for my $i(0 .. $#col){ - $hdr[@hdr]={'_'=>$col[$i],'i'=>$i} - } - }elsif(@col>0){ + if(@col>0){ ## #sel tbl section if(@spec){ @@ -259,7 +260,7 @@ try{ } } } - $self->{parser}->log("CNFParser-> Insert into $tbl -> ". join(',', @ins)."\n"); + $self->{parser}->log("CNFParser-> Insert into $tbl -> [". join(',', @ins)."]\n"); if($auto_increment){ $auto_increment--; splice @ins, $auto_increment, 1 @@ -339,10 +340,10 @@ sub getStatement { my ($self, $name) = @_; sub hasEntry{ my ($sel, $uid) = @_; return 0 if !$hasRecords; if(ref($uid) eq 'ARRAY'){ - $sel -> execute(@$uid) + $sel -> execute(@$uid+1) }else{ $uid=~s/^["']|['"]$//g; - $sel -> execute($uid) + $sel -> execute($uid+1) } my @r=$sel->fetchrow_array(); return scalar(@r); diff --git a/system/modules/DataProcessorPlugin.pm b/system/modules/DataProcessorPlugin.pm index d872b9d..05bf6f6 100644 --- a/system/modules/DataProcessorPlugin.pm +++ b/system/modules/DataProcessorPlugin.pm @@ -7,6 +7,8 @@ use feature qw(signatures); use Scalar::Util qw(looks_like_number); use Clone qw(clone); use Date::Manip; +use Syntax::Keyword::Try; +use Exception::Class ('PluginException'); use constant VERSION => '1.0'; @@ -17,11 +19,155 @@ sub new ($class, $plugin){ } return bless $settings, $class } +sub process ($self, $parser, $property) { + if($property eq '*'){ + foreach(keys %{$parser->data()}){ + my $table = $parser->data()->{$_}; + processProperty($self,$parser,$_); + unless($$table){} + } + return 1 + }else{ + return processProperty($self,$parser,$property) + } + return 0; + +} + +sub processProperty ($self, $parser, $property) { + my $table = $parser->data()->{$property}; + if(!$table){ + $parser->error("DataProcessorPlugin\@Error Table property not found -> $property") + }else{ + my (@hdr,@spec,$mod,$warnc,$knock_out); + my $ref = ref($table); +try{ + if( $ref ne 'REF'){ + $parser->warn("DataProcessorPlugin\@Error [$property] property table header has not been meta script set!"); + }elsif( $ref ne 'ARRAY'){ + my $ptr = $$table->{header}; + $ref = ref($ptr); + if($ref eq 'REF'){ + $ptr = $$ptr; + } + @hdr=@$ptr; + $ref =ref($hdr[0]); + if($ref eq 'ARRAY'){ + @spec = CNFMeta::_deRefArray($hdr[3]); + }else{ + if ($ref eq ''){ + $parser->warn("DataProcessorPlugin\@Error [$property] property table header is empty!"); + }else{ + @spec = CNFMeta::_deRefArray($hdr[3]); + } + } + + }else{ + die "CNF Table header not set!"; + } +### + my $cols = scalar @spec; + my @rows = @{$$table->{data}}; + for my $i (0 .. $#rows){ + my @row = CNFMeta::_deRefArray($rows[$i]); + if(@spec==0){ + #We assume first record is the header if hasn't been meta instructed. + for my $c (0 .. $#row){ + my $row_value = $row[$c]; $row_value =~ m/([\^#%\@\$]|)(.*)/g; + my $t = $1; $row_value = $2; + if($t eq '^'){ + $spec[$c] = $CNFMeta::CNF_DATA_TYPES{BOOL}; + }elsif($t eq '#' or $row_value eq 'ID'){ + $spec[$c] = $CNFMeta::CNF_DATA_TYPES{INT} + }elsif($t eq '%'){ + $spec[$c] = $CNFMeta::CNF_DATA_TYPES{NUMBER} + }elsif($t eq '@'){ + $spec[$c] = $CNFMeta::CNF_DATA_TYPES{DATE} + }else{ + $spec[$c] = $CNFMeta::CNF_DATA_TYPES{TEXT} + } + $row[$c] = $row_value + } + $cols = scalar @spec; + $$table->{header} = \[\@row,"","",\@spec]; + $knock_out = 1; + next + } + if(@row!=$cols){ + $parser->warn("Row in expected column count mismatch violation, row contents: @row") if !$warnc; + $warnc++ + } + for my $c (0 .. $#row){ + my $spec_type = $spec[$c]; + my $row_value = $row[$c]; + if(not _matchType($spec_type, $row_value)){ + warn "Row in row[$i]='$row[$i]' doesn't match expect data type, contents: @row"; + } + elsif($spec_type==$CNFMeta::CNF_DATA_TYPES{DATE}){ + my $dts = $row[$c]; + my $dt = UnixDate(ParseDateString($dts), "%Y-%m-%d %T"); + if($dt){ + $row[$c] = $dt; + $mod=1; + } + else{ + warn "Row in row[$i]='$dts' has imporper date format, contents: @row"; + } + }else{ + $row_value =~ s/^\s+|\s+$//gs if $spec_type!=$CNFMeta::CNF_DATA_TYPES{TEXT}; + if($spec_type==$CNFMeta::CNF_DATA_TYPES{BOOL}){ + $row_value = CNFParser::_isTrue($row_value); + } + elsif($spec_type==$CNFMeta::CNF_DATA_TYPES{INT}){ + unless($row_value){ + if($knock_out && $c == 0){ + #old way spec assume ID is first column that need autonumbering. + $row_value = $knock_out++; + }else{ + $row_value = 0 + } + } + else{$row_value=int($row_value);} + } + $row[$c] = $row_value; + $mod=1; + } + } + $rows[$i]=\@row if $mod; + }#rof + shift @rows if($knock_out); + $$table->{data} = \@rows; +}catch{ + PluginException->throw(error=>"

Error->$@


processProperty('$property')", show_trace=>1); +} + + } +return 1 +} +sub _zero_prefix ($times, $val) { + if($times>0){ + return '0'x$times.$val; + }else{ + return $val; + } +} +sub _matchType($type, $val, @rows) { + if ($type == $CNFMeta::CNF_DATA_TYPES{BOOL}){return 1} + elsif($type == $CNFMeta::CNF_DATA_TYPES{INT} || $type == $CNFMeta::CNF_DATA_TYPES{NUMBER} && looks_like_number($val)){return 1} + elsif($type== $CNFMeta::CNF_DATA_TYPES{DATE}){ + if($val=~/\d*\/\d*\/\d*/){return 1} + else{ + return 1; + } + } + elsif($type==$CNFMeta::CNF_DATA_TYPES{TEXT}){return 1} + return 0; +} ### # Process config data to contain expected fields and data. ### -sub process ($self, $parser, $property) { +sub processOLD ($self, $parser, $property) { my @data = $parser->data()->{$property}; # # The sometime unwanted side of perl is that when dereferencing arrays, @@ -70,7 +216,7 @@ sub process ($self, $parser, $property) { 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])){ + 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){ @@ -93,24 +239,7 @@ sub process ($self, $parser, $property) { } $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; diff --git a/system/modules/DataProcessorWorldCitiesPlugin.pm b/system/modules/DataProcessorWorldCitiesPlugin.pm index 04c9fb2..40a34b1 100644 --- a/system/modules/DataProcessorWorldCitiesPlugin.pm +++ b/system/modules/DataProcessorWorldCitiesPlugin.pm @@ -6,26 +6,30 @@ use warnings; use feature qw(signatures); use Scalar::Util qw(looks_like_number); - -sub new ($class,$plugin){ +# @Deprecated Plugin not needed anymore in script. +sub new ($class,$plugin){ return bless {}, $class } ### # Process config data to contain expected fields and data. +# This plugin isn't needed anymore in the script as the parser will process it. +# If you are getting errors from here that means your script is old and needs to be updated +# to have a __HAS_HEADER__ in the DATA instruction. ### 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; + my $table = $parser->data()->{$property}; + my @header = @{$$table->{header}}; + my @data = @{$$table->{data}}; + my @hdr = @{$header[0]}; + my @spec = @{$header[3]}; + $parser->data()->{$property} = \{ + name=>$property, + header=>\[\@hdr,"","",\@spec], + auto=>0, + data=>\@data } - $parser->data()->{$property} = \@data; } ### @@ -35,7 +39,7 @@ sub process ($self, $parser, $property) { sub loadAndProcess ($self, $parser, $property) { - my @data; + my @data; local $/ = undef; my $file = $parser->anon($property); open my $fh, '<', $file or die ("$!"); @@ -57,7 +61,7 @@ sub loadAndProcess ($self, $parser, $property) { } push @a, $v; } - else{ + 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. @@ -67,11 +71,17 @@ sub loadAndProcess ($self, $parser, $property) { push @a, $d; } } - } + } $data[@data]= \@a; } close $fh; - $parser->data()->{$property} = \@data; + our (@hdr,@spec)=(['CITY','LAT','LAG','COUNTRY','DM'],[5,5,5,5,5]); + $parser->data()->{$property} = \{ + name=>$property, + header=>\[\@hdr,"","",\@spec], + auto=>0, + data=>\@data + } } 1; diff --git a/system/modules/RSSFeedsPlugin.pm b/system/modules/RSSFeedsPlugin.pm index d0fc97a..81b644f 100644 --- a/system/modules/RSSFeedsPlugin.pm +++ b/system/modules/RSSFeedsPlugin.pm @@ -1,8 +1,7 @@ package RSSFeedsPlugin; use strict; -use warnings; -no warnings qw(experimental::signatures); +use warnings; no warnings qw(experimental::signatures); use feature qw(signatures); use Scalar::Util qw(looks_like_number); use Syntax::Keyword::Try; @@ -35,16 +34,34 @@ sub new ($class, $plugin){ # Process config data to contain expected fields. ### sub process ($self, $parser, $property) { - my @data = @{$parser->data()->{$property}}; + + my $table = $parser->data()->{$property}; + if(!$table){ + $parser->error("RSSFeedsPlugin\@Error Table property not foun -> $property"); return + } my $cgi = $parser->const('CGI'); $self->{date} = now(); + my $ptr = $$table->{header}; + my $ref = ref($ptr); + if($ref eq 'REF'){ + $ptr = $$ptr; + } + my @header = @$ptr; + my @data = @{$$table->{data}}; for my $idx (0 .. $#data){ my @col = @{$data[$idx]}; - if($idx>0){ + if($idx==0){ + $col[4] = 'last_updated'; + if(@header){ + my @lbls = CNFMeta::_deRefArray($header[0]); + my @spec = CNFMeta::_deRefArray($header[3]); + $lbls[4] = $col[4]; + $spec[4] = $CNFMeta::CNF_DATA_TYPES{DATE}; + $$table->{header} = \[\@lbls,$header[1],$header[2],\@spec]; + } + }else{ $col[0] = $idx+1; $col[4] = $self-> {date} -> toTimestamp(); - }else{ - $col[4] = 'last_updated'; } $data[$idx]=\@col; } @@ -61,25 +78,32 @@ sub process ($self, $parser, $property) { }else{ $parser->addPostParseProcessor($self,'collectFeeds'); } - $parser->data()->{$property} = \@data + $parser->data()->{$property} = \{name=>$property,header=>$$table->{header},auto=>0,data=>\@data} } sub collectFeeds($self, $parser) { my $property = $self->{property}; - my %hdr; - my @data = @{$parser->data()->{$property}}; - my $cgi = $parser->const('CGI'); + + my $table = $parser->data()->{$property}; + my $ptr = $$table->{header}; + my $ref = ref($ptr); + if($ref eq 'REF'){ + $ptr = $$ptr; + } my $page; + my @header = @$ptr; + my @data = @{$$table->{data}}; + my $cgi = $parser->const('CGI'); my $feed = $cgi->param('feed') if $cgi; - $parser->log("Feed request:$feed"); + my @lbls = CNFMeta::_deRefArray($header[0]); + my %hdr; + for(my $i=0;$i<@lbls;$i++){ #<- Column names are set here, if names in script are changed, They must be changed bellow. + $hdr{$lbls[$i]} = $i + } + $parser->log("Feed request:$feed") if$feed; for my $idx (0 .. $#data){ - my @col = @{$data[$idx]}; - if($idx==0){ - for my $i(0..$#col){ # Get the matching table column index names as scripted. - $hdr{$col[$i]} = $i - } - }else{ - my $name = $col[$hdr{Name}]; #<- Now use the column names as coded, if names in script are changed, you must change here. + my @col = @{$data[$idx]}; + my $name = $col[$hdr{Name}]; next if($feed && $feed ne $name); my $tree = fetchFeed($self, $name, $col[$hdr{URL}], $col[$hdr{Description}]); $parser->log("Fetched feed:".$name); @@ -102,7 +126,6 @@ sub collectFeeds($self, $parser) { }else{ $parser-> warn("Feed '$name' bailed to return a CNFNode tree.") } - } } $parser->data()->{PAGE} = \$page if $page; } diff --git a/test_commit b/test_commit deleted file mode 100644 index e69de29..0000000 diff --git a/tests/DataProcessorPlugin.pm b/tests/DataProcessorPlugin.pm deleted file mode 100644 index 809ccff..0000000 --- a/tests/DataProcessorPlugin.pm +++ /dev/null @@ -1,110 +0,0 @@ -package DataProcessorPlugin; - -use strict; -use warnings; - -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, $plugin){ - my $settings; - if($plugin){ - $settings = clone $plugin; #clone otherwise will get hijacked with blessings. - $settings->{Language}='English' if not exists $settings->{Language}; - $settings->{DateFormat}='US' if not exists $settings->{DateFormat} - }else{ - $settings = {Language=>'English',DateFormat=>'US'} - } - Date_Init("Language=".$settings->{Language},"DateFormat=".$settings->{DateFormat}); #<-- Hey! It is not mine fault, how Date::Manip handles parameters. - 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; - # Cleanup header label row for the columns, if present. - 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; - } - } - if($row[0]){ - shift @entry; - last - } - } - for my $eid (0 .. $#entry){ - 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 $size = @row; - $size = length(''.$size); - $row[0] = zero_prefix($size,$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"; - } - } - } - } - $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) { - return '0'x$times.$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; \ No newline at end of file diff --git a/tests/DatabaseCentralPlugin.pm b/tests/DatabaseCentralPlugin.pm index ff1a89e..9906232 100644 --- a/tests/DatabaseCentralPlugin.pm +++ b/tests/DatabaseCentralPlugin.pm @@ -23,7 +23,8 @@ sub new ($class, $plugin){ } sub getConfigFiles($self, $parser, $property){ my @dirs = $parser->property($property); - my @files = ['ID','path','size','lines','modified']; my $cnt=0; #We have to mimic CNF type entries. + my @hdr = ['ID','path','size','lines','modified']; my $cnt=0; #We have to mimic CNF type entries. + my @files; foreach(@dirs){ my @list = glob("$_/*.cnf $_/*.config"); foreach my$fl(@list){ @@ -39,9 +40,21 @@ sub getConfigFiles($self, $parser, $property){ push @files, [++$cnt,$fl,$size,$num_lines,$CNFDate] if @list } } - $parser->data()->{$self->{element}} = \@files; - + our @spec = [ + $CNFMeta::CNF_DATA_TYPES{INT}, + $CNFMeta::CNF_DATA_TYPES{TEXT}, + $CNFMeta::CNF_DATA_TYPES{NUMBER}, + $CNFMeta::CNF_DATA_TYPES{NUMBER}, + $CNFMeta::CNF_DATA_TYPES{DATE} + ]; + $parser-> data() -> {$self->{element}} = \{ + name=>$property, + header=>\[\@hdr,"","",\@spec], + auto=>0, + data=>\@files + } } + sub main ($self, $parser, $property) { my $item = $parser->anon($property); die "Property not found [$property]!" if !$item; @@ -79,20 +92,31 @@ sub main ($self, $parser, $property) { if($ref eq 'CNFNode'){ my @tables = @{$item -> find('table/*')}; warn "Not found any 'table/*' path elements for CNF property :". $item->name() if not @tables; +### foreach my $tbl(@tables){ if(processTable($db,$tbl)){ if($tbl -> {property}){ - my $process = processData($parser, $tbl -> {property}); + my $table = $parser->data()->{$tbl -> {property}}; my $dbsTblInsert = $db->prepare($tbl -> {sqlInsert}); - my @spec = @$process[0]; - my @hdrc = @$process[1]; - my @data = @$process[2]; + my $ptr = $$table->{header}; + my $ref = ref($ptr); + my @header; + if($ref eq 'REF'){ + $ptr = $$ptr; + @header = @$ptr; + }elsif($ref eq 'ARRAY'){ + @header = @$ptr; + } + if(@header==0){ + die "Table data header not established for $property->\[".$tbl->{property}."] has it been DataProcessorPlugin processed?"; + } +### my @idx = (); - my @map = @{$tbl -> {_MAPPING_}}; - my @hdr = @{$hdrc[0][0]}; - @data = @{$data[0][0]}; + my @map = CNFMeta::_deRefArray($tbl -> {_MAPPING_}); + my @hdr = CNFMeta::_deRefArray($header[0]); + my @spec = CNFMeta::_deRefArray($header[3]); ### - # Follwing is rare to see in code, my (wbudic) forward override conditional mapping algorithm, + # Following is rare to see in code, my (wbudic) forward override conditional mapping algorithm, # as actual data @row length could be larger to the relative column map, of what we are inserting. # I know, it looks like a unlocking a magick riddle. # @@ -102,23 +126,31 @@ sub main ($self, $parser, $property) { my $j=0; my $found =0; foreach (@map){ my @set = @$_; - if($set[0] eq $label){ + if($set[0] =~ m/^$label/i){ $idx[$j] = $i if $set[1] ne 'auto'; $found=1; last } $j++ } - warn "Not found data header mapped label-> $label for table -> ".$tbl -> {name} if ($found==0 && $label ne 'ID'); + if ($found==0 && $label ne 'ID'){ + warn "[$label] for table -> ".$tbl -> {name}." not found data header mapped label." + } } } + ### + my @data = @{$$table->{data}}; foreach (@data){ my @row = @{$_}; my @insert = @idx; for(my $i=0; $i<@idx; $i++){ $insert[$i] = $row[$idx[$i]] if $idx[$i] < @row } - $dbsTblInsert->execute(@insert) + try { + $dbsTblInsert->execute(@insert) + }catch{ + PluginException->throw(error=>"

Error->$@


property: $property\[".$tbl->{name}."] ->@insert
", show_trace=>1); + } } ### } @@ -175,78 +207,7 @@ sub processTable ($db, $node) { return 0; } -### -# Process config data to contain expected fields and data. -### -sub processData ($parser, $property) { - my @DATA = $parser->data()->{$property}; - my (@SPEC,@HDR); -# -# 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 $mod = 0; - # - # Build data type specs, obtain header mapping and cleanup header label row for the columns, - # if present. - foreach (@entry){ - my @row = @$_; - $ID_Spec_Size = scalar @row; - for my $i (0..$ID_Spec_Size-1){ - if($row[$i] =~ /^#/){ # Numberic - $SPEC[$i] = 1; - } - elsif($row[$i] =~ /^@/){ # DateTime - $SPEC[$i] = 2; - } - else{ - $SPEC[$i] = 3; # Text - } - } - if($row[0]){ - @HDR = shift @entry; - $DATA[$did]=\@entry; - last - } - } - for my $eid (0 .. $#entry){ - my @row = @{$entry[$eid]}; - if ($ID_Spec_Size){ - # If zero it is presumed ID field, corresponding to row number + 1 as our assumed autonumber max count. - if(defined $row[0] && $row[0] == 0){ - my $size = @row; - $size = length(''.$size); - $row[0] = zero_prefix($size,$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"; - } - } - } - } - $entry[$eid]=\@row if $mod; #<-- re-reference as we changed the row. Something hard to understand. - } - } - $DATA[$did]=\@entry if $mod; - } - return [\@SPEC, \@HDR, \@DATA]; -} + sub zero_prefix ($times, $val) { return '0'x$times.$val; } diff --git a/tests/TestManager.pm b/tests/TestManager.pm index 91acb4b..82d4811 100644 --- a/tests/TestManager.pm +++ b/tests/TestManager.pm @@ -203,8 +203,8 @@ sub doneFailed { ### sub dumpTermination { my ($failed, $comment, $past, $message, $ErrAt, $cterminated) = @_; - my ($file,$lnErr, $trace); - my $refT = ref($comment); + my ($file,$lnErr, $trace); + my $refT = ref($comment); if($refT eq 'Specio::Exception'){ my $trace = ""; my $i = 3; @@ -218,7 +218,7 @@ sub dumpTermination { #($file,$lnErr) =($st->filename(),$st->line()) } } - $comment = $message = $comment->{'message'}.$trace; + $comment = $message = $comment->{'message'}.$trace; $comment =~ s/eval \{.+\} at/cought at/gs; #Old die methods could be present, caught by an Exception, manually having Error@{lno.} set. if($message =~ /^Error\@(\d+)/){ @@ -261,7 +261,7 @@ sub dumpTermination { my $line = $slurp[$i]; if($. >= $lnErr+1){ print $comment, RESET.frmln($.).$line; - print "[".$file."]\n\t".BRIGHT_RED."Failed\@Line".WHITE." $i -> ", $slurp[$i-1].RESET; + print "[".$file."] Case $failed->{test_cnt} \n\t".BRIGHT_RED."Failed\@Line".WHITE." $i -> ", $slurp[$i-1].RESET; last }elsif($line=~m/^\s*(\#.*)/){ if( $1 eq '#'){ diff --git a/tests/dbSQLSetup.cnf b/tests/dbSQLSetup.cnf index 559f8bd..db96333 100644 --- a/tests/dbSQLSetup.cnf +++ b/tests/dbSQLSetup.cnf @@ -61,12 +61,21 @@ subroutine : main property : DB_SCHEMA >> + +< ___HAS_PROCESSING_PRIORITY___ + package : DataProcessorPlugin + subroutine : process + property : * +>> + + + ## Sample initial data here, if not of importance can be removed. ## Otherwise if updated here in script or if missing in the db, will be reinserted into it again. ## This behaviour is a feature. As the data or tables can be application specific ## and is part of script to data sychronisation after software upgrades. ## It is recommended if have a large set of data, to put this in a separate script data file, and wire that here instead. -< +< __HAS_HEADER__ ID`email`name`ID_ADDR~ #`sjulia@smiths.fake.com`Julia Smith`01~ #`speter@smiths.fake.com`Peter Smith`01~ @@ -132,7 +141,7 @@ ID`address`state`city`postcode`country~ 35`Income `Significant yearly income.~ >> -< +< __HAS_HEADER__ ID`Name`URL`Description~ #`Perl Weekly`https://perlweekly.com/perlweekly.rss`A free, once a week e-mail round-up of hand-picked news and articles about Perl. The Perl Weekly ( http://perlweekly.com/ ) is a newsletter including links to blog posts and other news items diff --git a/tests/example.cnf b/tests/example.cnf index a0f44f0..d635a09 100644 --- a/tests/example.cnf +++ b/tests/example.cnf @@ -124,7 +124,7 @@ Reach him at his Seoul office.~ CONTACTS property shows that a data row can contain in script multiple lines for column values. -< +< __HAS_HEADER__ __AUTO_NUMBERED__ ID`Name `Position `Office `Age `Start date `Salary~ #`Airi Satou `Accountant `Tokyo `33 `2008-11-28 `$162,700~ #`Angelica Ramos `Chief Executive Officer (CEO)`London `47 `2009-10-09 `$1,200,000~ diff --git a/tests/testCNFConstances.pl b/tests/testCNFConstances.pl index c60ff28..73d9627 100644 --- a/tests/testCNFConstances.pl +++ b/tests/testCNFConstances.pl @@ -118,11 +118,11 @@ try{ my $data = $cnf->anon('ACME_SAMPLE_StaffTable'); $test->isNotDefined('ACME_SAMPLE_StaffTable',$data); - $data = %{$cnf->data()}{'ACME_SAMPLE_StaffTable'}; + $data = $cnf->data() -> {'ACME_SAMPLE_StaffTable'}; $test->isDefined('ACME_SAMPLE_StaffTable',$data); # It is multi dimensional array and multi property stuff. print "## ACME_SAMPLE_StaffTable Members List\n"; - foreach (@$data[0]){ + foreach ($$data->{data}){ my @rows = @$_; foreach(@rows){ my @cols = @$_; @@ -139,4 +139,3 @@ catch{ $test -> dumpTermination($@); $test -> doneFailed(); } - diff --git a/tests/testSQL.pl b/tests/testSQL.pl index 9f8aeca..9e38f4e 100644 --- a/tests/testSQL.pl +++ b/tests/testSQL.pl @@ -47,7 +47,7 @@ try{ $test->evaluate("Is CNFSQl ref?","CNFSQL", ref($sql2)); # $test->nextCase(); - # + ### $test->case("Test RSS FEEDS Plugin."); my $plugin = $cnf->property('PROCESS_RSS_FEEDS'); $test->failed() if not $plugin; @@ -72,7 +72,7 @@ try{ "ID" INTEGER NOT NULL, PRIMARY KEY ("ID" AUTOINCREMENT) >> - < + < __HAS_HEADER__ ID`NAME`Gender~ #`Mickey Mouse`rat~ 5`Donald Duck`food~ diff --git a/tests/testWorldCitiesDataHandling.pl b/tests/testWorldCitiesDataHandling.pl index c31d949..bb1c09d 100644 --- a/tests/testWorldCitiesDataHandling.pl +++ b/tests/testWorldCitiesDataHandling.pl @@ -1,8 +1,8 @@ #!/usr/bin/env perl -use warnings; use strict; +use warnings; use strict; use Syntax::Keyword::Try; -use lib "./tests"; +use lib "tests"; use lib "system/modules"; require TestManager; @@ -19,58 +19,51 @@ try{ $test->case("Loading ./tests/world_cities.cnf.")->start(); die $test->failed() if not $cnf = CNFParser->new('./tests/world_cities_tmp.cnf',{DO_ENABLED=>1,ENABLE_WARNINGS=>1}); $test->stop(); - + # - $test->nextCase(); + $test->nextCase(); # $test->case("Obtain and display World Cities data."); - my $data = $cnf->data() -> + my $table = $cnf->data() -> {'WorldCities'}; - $test->isDefined('WorldCities',$data); + $test->isDefined('WorldCities',$table); - foreach(@$data){ - foreach(@$_){ - my @col = @$_; - print qq($col[0] \t\t $col[3]\n); - } + foreach(CNFMeta::_deRefArray($$table->{data})){ + my @col = @$_; + print qq($col[0] \t\t $col[3]\n); } $test->case("Select raw CNF data format from file."); - + my $cnt =0; - my @data2 = %{$cnf->data()} - {'World_Cities_From_Data_File'}; - $test->isDefined('World_Cities_From_Data_File',@data2); + my $table2 = %{$cnf->data()} + {'World_Cities_From_Data_File'}; + $test->isDefined('World_Cities_From_Data_File',$table2); + my @data2 = CNFMeta::_deRefArray($$table2->{data}); foreach(@data2){ - if(ref($_) eq 'ARRAY'){ - foreach(@$_){ - my @col = @$_; - print $col[0]."\t\t $col[3]\n"; - last if $cnt++>5 - } - } + my @col = @$_; + print $col[0]."\t\t $col[3]\n"; + last if $cnt++>5 } $test->case("Do an select based on domain."); $cnt =0; - foreach($data2[1]){ - foreach(@$_){ + foreach(@data2){ my @col = @$_; if($col[4] eq 'AU'){ print $col[0]."\t\t $col[3]\n"; - last if $cnt++>5 + last if ++$cnt>19 } - } - } + } + $test->evaluate("Selected at least 20 AU Cities?",20,$cnt); - # - $test->done(); + # + $test->done(); # } -catch{ - $test -> dumpTermination($@); +catch{ + $test -> dumpTermination($@); $test -> doneFailed(); } - diff --git a/tests/test_DATA_Instruction.pl b/tests/test_DATA_Instruction.pl index 73e091d..baa18a2 100644 --- a/tests/test_DATA_Instruction.pl +++ b/tests/test_DATA_Instruction.pl @@ -24,7 +24,7 @@ try{ # $test->case("Test standard header and DATA parsing."); $cnf->parse(undef,qq( -<< Sample_Data +<< Sample_Data __HAS_HEADER__ ID`name`desc~ 1`Mickey Mouse`Character owned by Disney.~ @@ -32,10 +32,11 @@ ID`name`desc~ >>)); my $sample = $cnf->data()->{Sample_Data}; $test->isDefined('$ample',$sample); - $test->evaluate('No. of rows is 3?', 3, scalar(@$sample)); + $sample = $$sample->{data}; + $test->evaluate('No. of rows is 2?', 2, scalar(@$sample)); my @array = @$sample; - $test->evaluate('$array[1][2] does match?', qq(Character -owned by Disney.), $array[1][2]); + $test->evaluate('$array[0][2] does match?', qq(Character +owned by Disney.), $array[0][2]); # $test-> nextCase(); # @@ -57,7 +58,8 @@ owned by Disney.), $array[1][2]); $test->case("Check DATA instruction dynamically"); $cnf->parse(undef,qq(<01`This comes from Cabramatta~\n>>)); $test->subcase("Contain 'my\$\$' as 'my' data property?"); - my @data = @{%{$cnf->data()}{'my'}}; + my $ref = $cnf->data()->{'my'}; + my @data = @{$$ref->{data}}; my @mydt = @{$data[0]}; $test->evaluate(\@mydt); $test->evaluate('01',$mydt[0]); diff --git a/tests/test_DATA_NEW_Instruction.pl b/tests/test_DATA_NEW_Instruction.pl new file mode 100644 index 0000000..93f9d02 --- /dev/null +++ b/tests/test_DATA_NEW_Instruction.pl @@ -0,0 +1,76 @@ +#!/usr/bin/env perl +use warnings; use strict; +use Syntax::Keyword::Try; + +use lib "tests"; +use lib "system/modules"; + +require TestManager; +require CNFParser; + +my $test = TestManager -> new($0); +my $cnf; + + +try{ + + $test -> case("CNFParser instance with CNFParser->new(undef,{'%LOG'=>{console=>1}})."); + die $test->failed() if not my $cnf = CNFParser->new(undef,{DO_ENABLED=>1,DEBUG=>1,'%LOG'=>{console=>1},TZ=>"Australia/Sydney"}); + $test -> nextCase(); + $test -> case("CNFParser parse data.."); + $cnf -> parse(undef,qq(!CNF3.2 + +<>> + +< + package : DataProcessorPlugin + subroutine : process + property : UserTable +>> + +<< UserTable __AUTONUMBER____ + +ID _ID_`Name`Age`Gender`Height`Married _BOOL_`DOB __DATE__~ + +#`Billy Bob +The Absolute Noob`12`95`red`0`2010-4-12~ +#`Jenny Jane`42`142`blue`true`1954-07-30~ +#`Steve McAlistaire`35`176`green`no`1982-11-04~ +>> + +<< UserTable +#`Billy Snob`22`95`blued`~ +>> + )); + + my $table = $cnf->data()->{UserTable}; + foreach($$table->{data}){ + foreach my $row(@$_){ + my $out = join ",", @$row; + $cnf->log($out) + } + } + ## + $test -> nextCase(); + ## + + $test -> case("Check is UserTable anon is assigned?"); + + my $anon = $cnf -> anon('UserTable'); + $test ->isDefined("$anon",$anon); + $test ->evaluate("Check value of \$anon?","This is an anon assignment same to property name bellow. It shall persist!",$anon); + + + + # + $test -> done(); + # +} +catch{ + $test -> dumpTermination($@); + $test -> doneFailed(); +} + +# +# TESTING THE FOLLOWING IS FROM HERE # +# \ No newline at end of file diff --git a/tests/world_cities_tmp.cnf b/tests/world_cities_tmp.cnf index 2b39100..7156887 100644 --- a/tests/world_cities_tmp.cnf +++ b/tests/world_cities_tmp.cnf @@ -1,7 +1,7 @@ ### # This is a tiny sample file only. With embedded data. ### -< +< __HAS_HEADER___ CITY`LAT`LAG`COUNTRY`DM~ Tokyo''`35.6839`139.7744`Japan`JP~ Jakarta`-6.2146`106.8451`Indonesia`ID~