-#!/usr/bin/perl -w
-#
-# Programed by: Will Budic
+# Main Parser for the Configuration Network File Format.
+# This source file is copied and usually placed in a local directory, outside of its project.
+# So not the actual or current version, might vary or be modiefied for what ever purpose in other projects.
+# Programed by : Will Budic
+# Source Origin : https://github.com/wbudic/PerlCNF.git
+# Documentation : Specifications_For_CNF_ReadMe.md
# Open Source License -> https://choosealicense.com/licenses/isc/
#
package CNFParser;
-use strict;
-use warnings;
-use Exception::Class ('CNFParserException');
+use strict;use warnings;#use warnings::unused;
+use Exception::Class ('CNFParserException');
use Syntax::Keyword::Try;
+use Hash::Util qw(lock_hash unlock_hash);
+use Time::HiRes qw(time);
+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)
+##no critic qw(Subroutines::RequireFinalReturn,ControlStructures::ProhibitMutatingListFunctions);
-our $VERSION = '2.2';
+use constant VERSION => '2.7';
-our %consts = ();
-our %mig = ();
-our @sql = ();
-our @files = ();
-our %tables = ();
-our %views = ();
-our %data = ();
-our %lists = ();
-our %anons = ();
-our %properties = ();
-sub new { my ($class, $path, $attrs, $self) = @_;
+our @files;
+our %lists;
+our %properties;
+our %instructors;
+our $CONSTREQ = 0;
+###
+# Package fields are always global in perl!
+###
+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, DATA=>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);
+sub isReservedWord {my ($self, $word)=@_; return $RESERVED_WORDS{$word}}
+###
+###
+# Create a new CNFParser instance.
+# $path - Path to some .cnf file, to parse, not compsuluory to add now.
+# $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;
-
+ $self = \%$attrs;
}else{
- $self = {"DO_enabled"=>0}; # Enable/Disable DO instruction.
+ $self = { #Case Sensitive don't tell me you set Do_enabled and it ain't working?
+ DO_enabled =>0, # Enable/Disable DO instruction. Which could evaluated potentially be an doom execute destruction.
+ ANONS_ARE_PUBLIC=>1, # Anon's are shared and global for all of instances of this object, by default.
+ ENABLE_WARNINGS =>1, # Disable this one, and you will stare into the void, on errors or operations skipped.
+ STRICT =>1, # Enable/Disable strict processing to FATAL on errors, this throws and halts parsing on errors.
+ DEBUG =>0 # Not internally used by the parser, but possible a convience bypass setting for code using it.
+ };
}
-
- bless $self, $class;
- $self->parse($path) if($path);
+ $CONSTREQ = $self->{'CONSTANT_REQUIRED'};
+ if (!$self->{'ANONS_ARE_PUBLIC'}){ #Not public, means are private to this object, that is, anons are not static.
+ $self->{'ANONS_ARE_PUBLIC'} = 0; #<- Caveat of Perl, if this is not set to zero, it can't be accessed legally in a protected hash.
+ $self->{'__ANONS__'} = {};
+ }
+ $self->{'__DATA__'} = {};
+ if(exists $self->{'%LOG'}){
+ 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.
+ bless $self, $class; $self->parse($path, undef, $del_keys) if($path);
return $self;
}
+#
+
+sub import {
+ my $caller = caller;
+ {
+ *{"${caller}::configDumpENV"} = \&dumpENV;
+ *{"${caller}::anon"} = \&anon;
+ *{"${caller}::SQL"} = \&SQL;
+ }
+ return 1;
+}
+
+###
+# Post parsing instructed special item objects.
+##
+package InstructedDataItem {
+
+ our $dataItemCounter = int(0);
+
+ sub new { my ($class, $ele, $ins, $val) = @_;
+ bless {
+ ele => $ele,
+ aid => $dataItemCounter++,
+ ins => $ins,
+ val => $val
+ }, $class
+ }
+ sub toString {
+ my $self = shift;
+ return "<<".$self->{ele}."<".$self->{ins}.">".$self->{val}.">>"
+ }
+}
+#
+
+###
+# PropertyValueStyle objects must have same rule of how an 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{
+ $self->{$p}=$itm;
+ undef $p;
+ }
+ }
+ }
+ }else{
+ warn "PropertyValue process what?"
+ }
+ bless $self, $class
+ }
+ sub result {
+ my ($self, $value) = @_;
+ $self->{value} = $value;
+ }
+}
+#
+###
+# 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
+}
-sub anon {
- my ($self, $n, @arg)=@_;
+###
+# 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 = $anons{$n};
+ my $ret = %$anechoic{$n};
return if !$ret;
- if(@arg){
- my $cnt = 1;
- foreach(@arg){
- $ret =~ s/\$\$\$$cnt\$\$\$/$_/g;
- $cnt++;
+ 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}
}
- }
+ }
+ return $$ret if ref($ret) eq "REF";
return $ret;
}
- return %anons;
+ return $anechoic;
+}
+
+# Validates and returns a constant named value as part of this configs instance.
+# Returns false if it doesn't exist.
+sub const { my ($self,$c)=@_;
+ if(exists $self->{$c}){
+ return $self->{$c}
+ }
+ return;
}
-sub constant {my $s=shift;if(@_ > 0){$s=shift;} return $consts{$s}}
-sub constants {return \%consts}
-sub collections {return \%properties}
-sub collection {my($self, $attr)=@_;return $properties{$attr}}
-sub data {return \%data}
+##
+# 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 includes, expecting thm 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}
+
+# Collection now returns the contained type dereferenced.
+# Make sure you use the appropriate Perl type on the receiving end.
+# Note, if properties contain any scalar key entry, it sure hasn't been set by this parser.
+sub collection { my($self, $name) = @_;
+ if(exists($properties{$name})){
+ my $ret = $properties{$name};
+ if(ref($ret) eq 'ARRAY'){
+ return @{$ret}
+ }else{
+ return %{$ret}
+ }
+ }
+ return %properties{$name}
+}
+sub data {shift->{'__DATA__'}}
sub listDelimit {
my ($this, $d , $t)=@_;
return;
}
sub lists {\%lists}
-sub list {my $t=shift;if(@_ > 0){$t=shift;} return @{$lists{$t}}}
-
-
-our %curr_tables = ();
-our $isPostgreSQL = 0;
-
-sub isPostgreSQL{shift; $isPostgreSQL}# Enabled here to be called externally.
-my %RESERVED_WORDS = (CONST=>1, DATA=>1, FILE=>1, TABLE=>1,
- INDEX=>1, VIEW=>1, SQL=>1, MIGRATE=>1, DO=>1, MACRO=>1 );
-sub isReservedWord {my ($self, $word)=@_; return $RESERVED_WORDS{$word}}
+sub list {
+ my $t=shift;if(@_ > 0){$t=shift;}
+ my $an = $lists{$t};
+ return @{$an} if defined $an;
+ die "Error: List name '$t' 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) = @_;
+sub addENVList { my ($self, @vars) = @_;
if(@vars){
foreach my $var(@vars){
- next if $consts{$var};##exists already.
+ next if $self->{$var};##exists already.
if((index $var,0)=='$'){#then constant otherwise anon
- $consts{$var} = $ENV{$var};
+ $self->{$var} = $ENV{$var};
}
else{
- $anons{$var} = $ENV{$var};
+ anon()->{$var} = $ENV{$var};
}
}
- }
+ }return;
}
-sub template {
- my ($self, $property, %macros) = @_;
- my $val = anons($self, $property);
+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;
- # print $val;
+ $val =~ s/$m/$v/gs;
}
my $prev;
foreach my $m(split(/\$\$\$/,$val)){
next;
}
undef $prev;
- my $pv = anons($self, $m);
- if(!$pv){
- $pv = constant($self, '$'.$m);
+ my $pv = $self->anon($m);
+ if(!$pv && exists $self->{$m}){
+ $pv = $self->{$m}#constant($self, '$'.$m);
}
if($pv){
$m = "\\\$\\\$\\\$".$m."\\\$\\\$\\\$";
return $val;
}
}
+#
-sub parse {
- my ($self, $cnf, $content) = @_;
-try{
+###
+# Parses a CNF file or a text content if specified, for this configuration object.
+##
+sub parse { my ($self, $cnf, $content, $del_keys) = @_;
+ my @tags;
my $DO_enabled = $self->{'DO_enabled'};
my %instructs;
- if(!$content){
- open(my $fh, "<:perlio", $cnf ) or die "Can't open $cnf -> $!";
- read $fh, $content, -s $fh;
+ our%includes;
+ my $anons;
+ if($self->{'ANONS_ARE_PUBLIC'}){
+ $anons = \%ANONS;
+ }else{
+ $anons = $self->{'__ANONS__'};
+ }
+ if(not $content){
+ open(my $fh, "<:perlio", $cnf ) or die "Can't open $cnf -> $!";
+ read $fh, $content, -s $fh;
close $fh;
+ my @stat = stat($cnf);
+ $self->{CNF_STAT} = \@stat;
+ $self->{CNF_CONTENT} = $cnf;
+ }else{
+ my $type =Scalar::Util::reftype($content);
+ if($type && $type eq 'ARRAY'){
+ $content = join "",@$content;
+ $self->{CNF_CONTENT} = 'ARRAY';
+ }
}
- my @tags = ($content =~ m/(<<)(<*.*?)(>>+)/gms);
-
+ $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};
+
+ unlock_hash(%$self);# We control from here the constances, need to unlock them if previous parse was run.
+
+ @tags = ($content =~ m/(<<)(<*.*?>*)(>>)/gms);
+
foreach my $tag (@tags){
next if not $tag;
next if $tag =~ m/^(>+)|^(<<)/;
if($tag=~m/^<CONST/){#constant multiple properties.
- foreach (split '\n', $tag){
- my $k;#place holder trick for split.
+ foreach (split '\n', $tag) {
+ my $k;
my @properties = map {
s/^\s+|\s+$//; # strip unwanted spaces
s/^\s*["']|['"]\s*$//g;#strip qoutes
s/<CONST\s//; # strip identifier
- s/\s>>//;
+ s/\s*>$//;
$_ # return the modified string
} split /\s*=\s*/, $_;
- foreach (@properties){
+ foreach (@properties) {
if ($k){
- $consts{$k} = $_ if not $consts{$k};
+ $self->{$k} = $_ if not $self->{$k};
undef $k;
}
else{
}
else{
- my ($st,$e,$t,$v, $v3, $i) = 0;
- my @vv = ($tag =~ m/(@|[\$@%]*\w*)(<|>)/g);
- $e = $vv[$i++]; $e =~ s/^\s*//g;
- die "Encountered invalid tag formatation -> $tag" if(!$e);
- # Is it <name><tag>value? Notce here, we are using here perls feature to return undef on unset array elements,
- # other languages throw exception. And reg. exp. set variables. So the folowing algorithm is for these languages unusable.
- while(defined $vv[$i] && $vv[$i] eq '>'){ $i++; }
- $i++;
- $t = $vv[$i++];
- $v = $vv[$i++];
- if(!$v&&!$t&& $tag =~ m/(.*)(<)(.*)/g){# Maybe it is the old format wee <<{name}<{instruction} {value}...
- $t = $1; if (defined $3){$v3 = $3}else{$v3 = ""} $v = $v3;
- my $w = ($v=~/(^\w+)/)[0];
- if(not defined $w){$w=""}
- if($e eq $t && $t eq $w){
- $i=-1;$t="";
- }elsif($RESERVED_WORDS{$w}){
- $t = $w;
- $i = length($e) + length($w) + 1;
- }else{
- if($v3){$i=-1;$t=$v} #$3 is containing the value, we set the tag to it..
- else{
- $i = length($e) + 1;
+ #vars are e-element,t-token or instruction,v- for value, vv -array of the lot.
+ my ($e,$t,$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;
+ $t = $2;
+ $v = substr($tag,length($e)+length($t));
+ $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 -> <https://github.com/wbudic/PerlCNF//CNF_Specs.md>
+ #@vv = ($tag =~ m/(@|[\$@%\W\w]*?)<(\w*)>(.*)/gsm);
+ #@vv = ($tag =~ m/([@%\w\$]*|\w*?)[<>]([@%\w\s\W]*)>*(.*)/gms);
+ @vv = ($tag =~ m/([@%\w\$\.\/]*|\w*?)[<>]([@%\w]*)>*(.*)/gms);
+ $e =$vv[0]; $t=$vv[1]; $v=$vv[2];
+ if(!$RESERVED_WORDS{$t} || @vv!=3){
+ if($tag =~ m/(@|[\$@%\W\w]*)<>(.*)/g){
+ $e =$1; $v=$2; $t = $v;
+ $self->warn("Encountered a mauled instruction tag: $tag\n")
+ }else{# Nope!? Let's continue mauling. Life is cruel, that's for sure.
+ @vv = ($tag =~ m/(@|[\$@%\W\w]*)<([.]*\s*)>*|(.*)>+|(.*)/gsm);
+ $e = shift @vv;#$e =~ s/^\s*//g;
+ if(!$e){
+ # From now on, parser mauls the tag before making out the value.
+ @vv = ($tag =~ m/(@|[\$@%]*\w*)(<|>)/g);
+ $e = shift @vv;
+ $t = shift @vv;
+ if(!$e){
+ if($self->{ENABLE_WARNINGS}){
+ $self->warn("Encountered invalid tag formation -> <<$tag>>");
+ }else{
+ die "Encountered invalid tag formation -> <<$tag>>"
+ }
+ }
+ $v = shift @vv;
+ }else{
+ if($e=~/[@%]/){
+ $v =~ /^<(.*)>$/gms;
+ $v = $1 if $1;
+ }else{
+ do{ $t = shift @vv; } while( !$t && @vv>0 ); $t =~ s/\s$//;
+ $v = shift @vv;
+ if(!$v){
+ if(@vv==0 && !$RESERVED_WORDS{$t}){#<- The instruction is assumed to hold the value if it isn't an reserved word.
+ $v = $t
+ }
+ foreach(@vv){#<- Attach any valid fallback from complex rexp.
+ $v .= $_ if $_;
+ }
+ }
+ }
}
}
- $v = substr $tag, $i if $i>-1; $v3 = '_V3_SET';
-
- }elsif (!$t && $v =~ /[><]/){ #it might be {tag}\n closed, as supposed to with '>'
- my $l = length($e);
- $i = index $tag, "\n";
- $t = substr $tag, $l + 1 , $i -$l - 1;
- $v3 = '_SUBS1_SET';
- }else{
- $i = length($e) + length($t) + ($i - 3);
- $v3 = '_SUBS2_SET';
+ }else{
+ $v =~ s/\s>$// ; #Strip if old format of instruction. Pre v.2.5.
}
-
- #trim accidental spacing in property value or instruction tag
- $t =~ s/^\s+//g;
- # Here it gets tricky as rest of markup in the whole $tag could contain '<' or '>' as text characters, usually in multi lines.
- $v = substr $tag, $i if $v3 ne '_V3_SET';
- $v =~ s/^[><\s]*//g if $v3 ne '_SUBS1_SET';
-
- # print "<<$e>>\nt:<<$t>>\nv:<<$v>>\n\n";
-
- if($e eq '@'){#collection processing.
- my $isArray = $t=~ m/^@/;
+ #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($t ne 'DATA'){
+ my $array = $lists{$e};
+ if(!$array){$array=();$lists{$e} = \@{$array};}
+ push @{$array}, InstructedDataItem -> new($e, $t, $v);
+ next
+ }
+ }elsif ($e eq '@'){#collection processing.
+ my $isArray = $t=~ m/^@/;
+ if(!$v && $t =~ m/(.*)>(\s*.*\s*)/gms){
+ $t = $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 qoutes
- s/\s>>//;
+ s/^\s*["']|['"]$//g;#strip quotes
+ #s/>+//;# strip dangling CNF tag
$_ ? $_ : undef # return the modified string
} @lst;
if($isArray){
- my @arr=(); $properties{$t}=\@arr;
- foreach (@props){
- push @arr, $_ if( length($_)>0);
+ if($self->isReservedWord($t)){
+ $self->warn("ERROR collection is trying to use a reserved property name -> $t.");
+ next
+ }else{
+ my @arr=();
+ foreach (@props){
+ push @arr, $_ if($_ && length($_)>0);
+ }
+ $properties{$t}=\@arr;
}
}else{
- my %hsh=(); $properties{$t}=\%hsh; my $macro = 0;
- foreach my $p(@props){
- if($p eq 'MACRO'){$macro=1}
+ my %hsh;
+ my $macro = 0;
+ if(exists($properties{$t})){
+ if($self->isReservedWord($t)){
+ $self->warn("Skipped overwritting reserved property -> $t.");
+ next
+ }else{
+ %hsh = %{$properties{$t}}
+ }
+ }else{
+ %hsh =();
+ }
+ foreach my $p(@props){
+ if($p && $p eq 'MACRO'){$macro=1}
elsif( $p && length($p)>0 ){
- my @pair = split(/\s*=\s*/, $p);
- die "Not '=' delimited-> $p" if scalar( @pair ) != 2;
- my $name = $pair[0]; $name =~ s/^\s*|\s*$//g;
- my $value = $pair[1]; $value =~ s/^\s*["']|['"]$//g;#strip qoutes
+ 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){
- foreach my $find($v =~ /(\$.*\$)/g) {
- my $s= $find; $s =~ s/^\$\$\$|\$\$\$$//g;
- my $r = $anons{$s};
- $r = $consts{$s} if !$r;
+ 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;
- die "Unable to find property for $t.$name -> $find\n" if !$r;
- $value =~ s/\Q$find\E/$r/g;
+ CNFParserException->throw(error=>"Unable to find property for $t.$name -> $find\n",show_trace=>1) if !$r;
+ $value =~ s/\Q$find\E/$r/g;
}
}
- $hsh{$name}=$value;
+ $hsh{$name}=$value; $self->log("macro $t.$name->$value\n") if $self->{DEBUG}
}
}
+ $properties{$t}=\%hsh;
}
next;
}
if($t eq 'CONST'){#Single constant with mulit-line value;
- $v =~ s/^\s// if $v;
- $consts{$e} = $v if not $consts{$e}; # Not allowed to overwrite constant.
- }elsif($t eq 'DATA'){
+ $v =~ s/^\s//;
+ #print "[[$t]]=>{$v}\n";
+ $self->{$e} = $v if not $self->{$e}; # Not allowed to overwrite constant.
+
+ }elsif($t eq 'DATA'){
+ $v=~ s/^\n//;
foreach(split /~\n/,$v){
my @a;
$_ =~ s/\\`/\\f/g;#We escape to form feed the found 'escaped' backtick so can be used as text.
foreach my $d (split /`/, $_){
$d =~ s/\\f/`/g; #escape back form feed to backtick.
+ $d =~ s/~$//; #strip dangling ~ if there was no \n
$t = substr $d, 0, 1;
if($t eq '$'){
- $v = $d; #capture spected value.
+ $v = $d; #capture specked value.
$d =~ s/\$$|\s*$//g; #trim any space and system or constant '$' end marker.
if($v=~m/\$$/){
- $v = $consts{$d}; $v="" if not $v;
+ $v = $self->{$d}; $v="" if not $v;
}
else{
$v = $d;
}
push @a, $v;
}
- else{
- #First is always ID a number and '#' signifies number.
- if($t eq "\#") {
- $d = substr $d, 1;
+ else{
+ if($t =~ /^\#(.*)/) {#First is usually ID a number and also '#' signifies number.
+ $d = $1;#substr $d, 1;
$d=0 if !$d; #default to 0 if not specified.
push @a, $d
}
}
}
- my $existing = $data{$e};
+ my $existing = $self->{'__DATA__'}{$e};
if(defined $existing){
my @rows = @$existing;
push @rows, [@a] if scalar @a >0;
- $data{$e} = \@rows
+ $self->{'__DATA__'}{$e} = \@rows
}else{
my @rows; push @rows, [@a];
- $data{$e} = \@rows if scalar @a >0;
+ $self->{'__DATA__'}{$e} = \@rows if scalar @a >0;
}
- }
- next;
+ }
+
}elsif($t eq 'FILE'){
-
- my ($i,$path) = $cnf;
- $v=~s/\s+//g;
- $path = substr($path, 0, rindex($cnf,'/')) .'/'.$v;
- push @files, $path;
- next if(!$consts{'$AUTOLOAD_DATA_FILES'});
- open(my $fh, "<:perlio", $path ) or CNFParserException->throw("Can't open $path -> $!");
- read $fh, $content, -s $fh;
- close $fh;
- my @tags = ($content =~ m/<<(\w*<(.*?).*?>>)/gs);
- foreach my $tag (@tags){
- next if not $tag;
- my @kv = split /</,$tag;
- $e = $kv[0];
- $t = $kv[1];
- $i = index $t, "\n";
- if($i==-1){
- $t = $v = substr $t, 0, (rindex $t, ">>");
- }
- else{
- $v = substr $t, $i+1, (rindex $t, ">>")-($i+1);
- $t = substr $t, 0, $i;
- }
- if($t eq 'DATA'){
- foreach(split /~\n/,$v){
- my @a;
- $_ =~ s/\\`/\\f/g;#We escape to form feed the found 'escaped' backtick so can be used as text.
- foreach my $d (split(/`/, $_)){
- $d =~ s/\\f/`/g; #escape back form feed to backtick.
- $t = substr $d, 0, 1;
- if($t eq '$'){
- $v = $d; #capture spected value.
- $d =~ s/\$$|\s*$//g; #trim any space and system or constant '$' end marker.
- if($v=~m/\$$/){
- $v = $consts{$d}; $v="" if not $v;
- }
- else{
- $v = $d;
- }
- push @a, $v;
+ my ($i,$path) = $cnf;
+ $v=~s/\s+//g;
+ $path = substr($path, 0, rindex($cnf,'/')) .'/'.$v;
+ push @files, $path;
+ next if !$self->{'$AUTOLOAD_DATA_FILES'};
+ open(my $fh, "<:perlio", $path ) or CNFParserException->throw("Can't open $path -> $!");
+ read $fh, $content, -s $fh;
+ close $fh;
+ my @tags = ($content =~ m/<<(\w*<(.*?).*?>>)/gs);
+ foreach my $tag (@tags){
+ next if not $tag;
+ my @kv = split /</,$tag;
+ $e = $kv[0];
+ $t = $kv[1];
+ $i = index $t, "\n";
+ if($i==-1){
+ $t = $v = substr $t, 0, (rindex $t, ">>");
+ }
+ else{
+ $v = substr $t, $i+1, (rindex $t, ">>")-($i+1);
+ $t = substr $t, 0, $i;
+ }
+ if($t eq 'DATA'){
+ foreach(split /~\n/,$v){
+ my @a;
+ $_ =~ s/\\`/\\f/g;#We escape to form feed the found 'escaped' backtick so can be used as text.
+ foreach my $d (split(/`/, $_)){
+ $d =~ s/\\f/`/g; #escape back form feed to backtick.
+ $t = substr $d, 0, 1;
+ if($t eq '$'){
+ $v = $d; #capture spected value.
+ $d =~ s/\$$|\s*$//g; #trim any space and system or constant '$' end marker.
+ if($v=~m/\$$/){
+ $v = $self->{$d}; $v="" if not $v;
}
else{
- #First is always ID a number and '#' signifies number.
- if($t eq "\#") {
- $d = substr $d, 1;
- $d=0 if !$d; #default to 0 if not specified.
- push @a, $d
- }
- else{
- push @a, $d;
- }
- }
-
- my $existing = $data{$e};
- if(defined $existing){
- my @rows = @$existing;
- push @rows, [@a] if scalar @a >0;
- $data{$e} = \@rows
- }else{
- my @rows; push @rows, [@a];
- $data{$e} = \@rows if scalar @a >0;
+ $v = $d;
}
- }
- }
- }
- }
- next
- }
- elsif($t eq 'TABLE'){
- $st = "CREATE TABLE $e(\n$v);";
- $tables{$e} = $st;
- next;
- }
- elsif($t eq 'INDEX'){
- $st = "CREATE INDEX $v;";
+ push @a, $v;
+ }
+ else{
+ if($t =~ /^\#(.*)/) {#First is usually ID a number and also '#' signifies number.
+ $d = $1;#substr $d, 1;
+ $d=0 if !$d; #default to 0 if not specified.
+ push @a, $d
+ }
+ else{
+ push @a, $d;
+ }
+ }
+ 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;
+ }
+ }
+ }
+ }
+ }
+ }elsif($t eq 'INCLUDE'){
+ $includes{$e} = {loaded=>0,path=>$e,v=>$v};
+ }elsif($t eq 'TREE'){
+ my $tree = CNFNode->new({'_'=>$e,script=>$v});
+ $tree->{DEBUG} = $self->{DEBUG};
+ $instructs{$e} = $tree;
+
+ }elsif($t eq 'TABLE'){ # This has now be late bound and send to the CNFSQL package. since v.2.6
+ SQL()->createTable($e,$v) } # It is hardly been used. But in future itt might change.
+ elsif($t eq 'INDEX'){ SQL()->createIndex($v)}
+ elsif($t eq 'VIEW'){ SQL()->createView($e,$v)}
+ elsif($t eq 'SQL'){ SQL($e,$v)}
+ elsif($t eq 'MIGRATE'){SQL()->migrate($e, $v)
}
- elsif($t eq 'VIEW'){
- $st = "CREATE VIEW $e AS $v;";
- $views{$e} = $st;
- next;
+ elsif($t eq 'DO'){
+ if($DO_enabled){
+ ## no critic BuiltinFunctions::ProhibitStringyEval
+ $v = eval $v;
+ ## use critic
+ chomp $v; $anons->{$e} = $v;
+ }else{
+ $self->warn("Do_enabled is set to false to process property: $e\n")
+ }
}
- elsif($t eq 'SQL'){
- $anons{$e} = $v;
+ elsif($t 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($t eq 'MIGRATE'){
- my @m = $mig{$e};
- @m = () if(!@m);
- push @m, $v;
- $mig{$e} = [@m];
+ elsif($t eq 'INSTRUCTOR'){
+ if(not $self->registerInstructor($e, $v) && $self->{STRICT}){
+ CNFParserException->throw("Instruction Registration Failed for '<<$e<$t>$v>>'!\t");
+ }
}
- elsif($DO_enabled && $t eq 'DO'){
- $anons{$e} = eval $v;
+ elsif(exists $instructors{$t}){
+ if(not $instructors{$t}->instruct($e, $v) && $self->{STRICT}){
+ CNFParserException->throw("Instruction processing failed for '<<$e<$t>>'!\t");
+ }
}
- elsif($t eq 'MACRO'){
- %instructs = () if(not %instructs);
- $instructs{$e}=$v;
+ elsif($t eq 'MACRO'){
+ $instructs{$e}=$v;
}
else{
- #Register application statement as either an anonymouse one. Or since v.1.2 an listing type tag.
+ #Register application statement as either an anonymous one. Or since v.1.2 an listing type tag.
if($e !~ /\$\$$/){ #<- It is not matching {name}$$ here.
+ $v = $t if not $v;
if($e=~/^\$/){
- $consts{$e} = $v if !$consts{$e}; # Not allowed to overwrite constant.
- }else{
- if(defined $t && length($t)>0){ #unknow tagged instructions value we parse for macros.
- %instructs = () if(not %instructs);
- $instructs{$e}=$t;
- }else{
- $anons{$e} = $v # It is allowed to overwite and abuse anons.
- }
+ $self->{$e} = $v if !$self->{$e}; # Not allowed to overwrite constant.
+ }else{
+ $anons->{$e} = $v
}
}
else{
- $e = substr $e, 0, (rindex $e, '$$')-1;
+ $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 $a = $lists{$e};
- if(!$a){$a=();$lists{$e} = \@{$a};}
- push @{$a}, $v;
- }
- next;
- }
- push @sql, $st;#push as application statement.
+ my $array = $lists{$e};
+ if(!$array){$array=();$lists{$e} = \@{$array};}
+ push @{$array}, $v;
+ }
+ }
}
}
- if(%instructs){ my $v;
+ #Do smart instructions and property linking.
+ if(%instructs){
+ my @ditms;
foreach my $e(keys %instructs){
- my $t = $instructs{$e}; $v=$t; #<--Instructions assumed as a normal value, case: <<{name}<{instruction}>>>
- foreach my $find($t =~ /(\$.*\$)/g) {
- my $s= $find; $s =~ s/^\$\$\$|\$\$\$$//g;
- my $r = $anons{$s};
- $r = $consts{$s} if !$r;
- die "Unable to find property for $e-> $find\n" if !$r;
- $v = $t;
- $v =~ s/\Q$find\E/$r/g;
- $t = $v;
+ 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{
+ $ditms[@ditms] = $struct;
}
- $anons{$e}=$v;
- }undef %instructs;
- }
-}catch{
- CNFParserException->throw(error=>$@, show_trace=>1);
-}
-}
-
-##
-# Required to be called when using CNF with an database based storage.
-# This subrotine is also a good example why using generic driver is not recomended.
-# Various SQL db server flavours meta info is def. handled differently and not updated in them.
-#
-sub initiDatabase {
- my($self,$db,$do_not_auto_synch)=@_;
- my $st = shift;
- my $dbver = shift;
-
-#Check and set CNF_CONFIG
-try{
-
- $isPostgreSQL = $db-> get_info( 17) eq 'PostgreSQL';
-
- if($isPostgreSQL){
- my @tbls = $db->tables(undef, 'public'); #<- This is the proper way, via driver, doesn't work on sqlite.
- foreach (@tbls){
- my $t = uc substr($_,7); $t =~ s/^["']|['"]$//g;
- $curr_tables{$t} = 1;
- }
- }
- else{
- my $pst = selectRecords($self, $db, "SELECT name FROM sqlite_master WHERE type='table' or type='view';");
- while(my @r = $pst->fetchrow_array()){
- $curr_tables{$r[0]} = 1;
- }
- }
-
- if(!$curr_tables{CNF_CONFIG}){
- my $stmt;
- if($isPostgreSQL){
- $stmt = qq|
- CREATE TABLE CNF_CONFIG
- (
- NAME character varying(16) NOT NULL,
- VALUE character varying(128) NOT NULL,
- DESCRIPTION character varying(256),
- CONSTRAINT CNF_CONFIG_pkey PRIMARY KEY (NAME)
- )|;
- }else{
- $stmt = qq|
- CREATE TABLE CNF_CONFIG (
- NAME VCHAR(16) NOT NULL,
- VALUE VCHAR(128) NOT NULL,
- DESCRIPTION VCHAR(256)
- )|;
- }
- $db->do($stmt);
- print "CNFParser-> Created CNF_CONFIG table.";
- $st = $db->prepare('INSERT INTO CNF_CONFIG VALUES(?,?,?);');
- $db->begin_work();
- foreach my $key($self->constants()){
- my ($dsc,$val);
- $val = $self->constant($key);
- my @sp = split '`', $val;
- if(scalar @sp>1){$val=$sp[0];$dsc=$sp[1];}else{$dsc=""}
- $st->execute($key,$val,$dsc);
- }
- $db->commit();
- }else{
- my $sel = $db->prepare('SELECT VALUE FROM CNF_CONFIG WHERE NAME LIKE ?;');
- my $ins = $db->prepare('INSERT INTO CNF_CONFIG VALUES(?,?,?);');
- foreach my $key(sort keys %{$self->constants()}){
- my ($dsc,$val);
- $val = $self->constant($key);
- my @sp = split '`', $val;
- if(scalar @sp>1){$val=$sp[0];$dsc=$sp[1];}else{$dsc=""}
- $sel->execute($key);
- if(!$sel->fetchrow_array()){
- $ins->execute($key,$val,$dsc);
- }
}
- }
- # By default we automatically data insert synchronize script with database state on every init.
- # If set $do_not_auto_synch = 1 we skip that if table is present, empty or not,
- # and if has been updated dynamically that is good, what we want. It is of external config. implementation choice.
- foreach my $tbl(keys %tables){
- if(!$curr_tables{$tbl}){
- $st = $tables{$tbl};
- print "CNFParser-> SQL: $st\n";
- $db->do($st);
- print "CNFParser-> Created table: $tbl\n";
- }
- else{
- next if $do_not_auto_synch;
- }
- if(isPostgreSQL()){
- $st = lc $tbl; #we lc, silly psql is lower casing meta and case sensitive for internal purposes.
- $st="select column_name, data_type from information_schema.columns where table_schema = 'public' and table_name = '$st';";
- print "CNFParser-> $st", "\n";
- $st = $db->prepare($st);
- }else{
- $st = $db->prepare("pragma table_info($tbl)");
+ for my $idx(0..$#ditms) {
+ my $struct = $ditms[$idx];
+ my $type = ref($struct);
+ if($type eq 'CNFNode' && $struct->{'script'}=~/_HAS_PROCESSING_PRIORITY_/si){
+ $struct->validate($struct->{'script'}) if $self->{ENABLE_WARNINGS};
+ $anons->{$struct->{'_'}} = $struct->process($self, $struct->{'script'});
+ splice @ditms, $idx,1;
+ }
}
- $st->execute();
- my $q =""; my @r;
- while(@r=$st->fetchrow_array()){ $q.="?,"; } $q =~ s/,$//;
- my $ins = $db->prepare("INSERT INTO $tbl VALUES($q);");
- $st="SELECT * FROM $tbl where ".getPrimaryKeyColumnNameWherePart($db, $tbl);
- print "CNFParser-> $st\n";
- my $sel = $db->prepare($st);
- @r = data($tbl);
- $db->begin_work();
- foreach my $rs(@r){
- my @cols=split(',',$rs);
- # If data entry already exists in database, we skip and don't force or implement an update,
- # as potentially such we would be overwritting possibly changed values, and inserting same pk's is not allowed as they are unique.
- next if hasEntry($sel, $cols[0]);
- print "CNFParser-> Inserting into $tbl -> $rs\n";
- $ins->execute(@cols);
+ for my $idx(0..$#ditms) {
+ my $struct = $ditms[$idx];
+ my $type = ref($struct);
+ if($type eq 'CNFNode'){
+ $struct->validate($struct->{'script'}) if $self->{ENABLE_WARNINGS};
+ $anons->{$struct->{'_'}} = $struct->process($self, $struct->{'script'});
+ splice @ditms, $idx,1;
+ }
}
- $db->commit();
- }
- foreach my $view(keys %views){
- if(!$curr_tables{$view}){
- $st = $views{$view};
- print "CNFParser-> SQL: $st\n";
- $db->do($st);
- print "CNFParser-> Created view: $view\n";
+ @ditms = sort {$a->{aid} <=> $b->{aid}} @ditms;
+ foreach my $struct(@ditms){
+ my $type = ref($struct);
+ if($type eq 'InstructedDataItem'){
+ my $t = $struct->{ins};
+ if($t eq 'PLUGIN'){ #for now we keep the plugin instance.
+ try{
+ $properties{$struct->{'ele'}} = doPlugin($self, $struct, $anons);
+ $self->log("Plugin instructed ->". $struct->{'ele'});
+ }catch{
+ if($self->{STRICT}){
+ CNFParserException->throw(error=>@_,trace=>1);
+ }else{
+ $self->trace("Error @ Plugin -> ". $struct->toString() ." Error-> $@")
+ }
+ }
+ }
+ }
}
+ undef %instructs;
}
- # Following is not been kept no more for external use.
- undef %tables;
- undef %views;
- undef %mig;
-}
-catch{
- CNFParserException->throw(error=>$@, show_trace=>1);
-}
-$self -> constant('$RELEASE_VER');
-}
-
-sub hasEntry{
- my ($sel, $uid) = @_;
- $uid=~s/^["']|['"]$//g;
- $sel->execute($uid);
- return scalar( $sel->fetchrow_array() );
-}
-sub getPrimaryKeyColumnNameWherePart {
- my ($db,$tbl) = @_; $tbl = lc $tbl;
- my $sql = $isPostgreSQL ? qq(SELECT c.column_name, c.data_type
-FROM information_schema.table_constraints tc
-JOIN information_schema.constraint_column_usage AS ccu USING (constraint_schema, constraint_name)
-JOIN information_schema.columns AS c ON c.table_schema = tc.constraint_schema
- AND tc.table_name = c.table_name AND ccu.column_name = c.column_name
-WHERE constraint_type = 'PRIMARY KEY' and tc.table_name = '$tbl') :
-qq(PRAGMA table_info($tbl););
-my $st = $db->prepare($sql); $st->execute();
-my @r = $st->fetchrow_array();
-if(!@r){
- CNFParserException->throw(error=> "Table missing or has no Primary Key -> $tbl", show_trace=>1);
-}
- if($isPostgreSQL){
- return $r[0]."=?";
- }else{
- # sqlite
- # cid[0]|name|type|notnull|dflt_value|pk<--[5]
- while(!$r[5]){
- @r = $st->fetchrow_array();
- if(!@r){
- CNFParserException->throw(error=> "Table has no Primary Key -> $tbl", show_trace=>1);
+ #Do scripted includes.
+ my @inc = sort values %includes;
+ $includes{$0} = {loaded=>1,path=>$self->{CNF_CONTENT}}; #<- to prevent circular includes.
+ foreach my $file(@inc){
+ if(!$file->{loaded} && $file->{path} ne $self->{CNF_CONTENT}){
+ if(open(my $fh, "<:perlio", $file->{path} )){
+ read $fh, $content, -s $fh;
+ close $fh;
+ if($content){
+ $file->{loaded} = 1;
+ $self->parse(undef, $content)
+ }else{
+ $self->error("Include content is blank for -> ".$file->{path})
+ }
+ }else{
+ CNFParserException->throw("Can't open ".$file->{path}." -> $!") if $self->{STRICT};
+ $file->{loaded} = 1;
+ $self->error("Include not available -> ".$file->{path})
}
}
- return $r[1]."=?";
+ }
+ foreach my $k(@$del_keys){
+ delete $self->{$k} if exists $self->{$k}
}
+ lock_hash(%$self);#Make repository finally immutable.
}
+#
-sub selectRecords {
- my ($self, $db, $sql) = @_;
- if(!$db||!$sql){
- die "Wrong number of arguments, expecting CNFParser::selectRecords(\$db, \$sql) got Settings::selectRecords('@_').\n";
- }
- try{
- my $pst = $db->prepare($sql);
- return 0 if(!$pst);
- $pst->execute();
- return $pst;
- }catch{
- CNFParserException->throw(error=>"Database error encountered!\n ERROR->$@\n SQL-> $sql DSN:".$db, show_trace=>1);
- };
-}
-#@deprecated
-sub tableExists {
- my ($self, $db, $tbl) = @_;
- try{
- $db->do("select count(*) from $tbl;");
- return 1;
-
- }catch{
- return 0;
+our $SQL;
+sub SQL {
+ if(!$SQL){##It is late compiled on demand.
+ require CNFSQL; $SQL = CNFSQL->new();
}
+ $SQL->addStatement(@_) if @_;
+ return $SQL;
}
-
###
-# Buffer loads initiated a file for sql data instructions.
-# TODO 2020-02-13 Under development.
-#
-sub initLoadDataFile {
- my($self, $path) = @_;
-return 0;
+# 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);
+ foreach my $ln(split(/\n/,$body)){
+ my @pair = $ln =~ /\s*(\w+)[:=](.*)\s*/;
+ my $ins = $1; $ins = $ln if !$ins;
+ my $mth = $2;
+ if($ins =~ /[a-z]/){
+ $args{$ins} = $mth;
+ next
+ }
+ 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;
}
+
###
-# Reads next collection of records into buffer.
-# returns 2 if reset with new load.
-# returns 1 if done reading data tag value, last block.
-# returns 0 if done reading file, same as last block.
-# readNext is accessed in while loop,
-# filling in a block of the value for a given CNF tag value.
-# Calling readNext, will clear the previous block of data.
-# TODO 2020-02-13 Under development.
-#
-sub readNext(){
-return 0;
+# 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";
+ my $obj;
+ my $settings = $properties{'%Settings'};#Properties are global.
+ if($settings){
+ $obj = $pck->new(\%$settings);
+ }else{
+ $obj = $pck->new();
+ }
+ my $res = $obj->$sub($self,$prp);
+ if($res){
+ 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 -> 'library', 'property' and 'subroutine')
+ }
}
-# Writes out to handle an property.
-sub writeOut { my ($self, $handle, $property) = @_;
+# 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 = "<<<CONST\n";
+ my $with = 5;
+ foreach (@keys){
+ my $len = length($_);
+ $with = $len + 1 if $len > $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){
- print $handle "<<@<$property><\n";
+ $buffer = "<<@<$property>\n";
if(ref $prp eq 'ARRAY') {
my @arr = sort keys @$prp; my $n=0;
foreach (@arr){
- print $handle "\"$_\"";
+ $buffer .= "\"$_\"";
if($arr[-1] ne $_){
- if($n++>5){print $handle "\n"; $n=0}
- else{print $handle ",";}
+ 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){
- print $handle $key . "\t= \"". $hsh{$key} ."\"\n";
+ $buffer .= $key . "\t= \"". $hsh{$key} ."\"\n";
}
}
- print $handle ">>>\n";
-
- return 1;
+ $buffer .= ">>\n";
+ return $buffer if !$handle;
+ print $handle $buffer;
+ return 1;
}
else{
- $prp = $anons{$property};
- $prp = $consts{$property} if !$prp;
- die "Property not found -> $property" if !$prp;
- print $handle "<<$property><$prp>>\n";
+ $prp = $ANONS{$property};
+ $prp = $self->{$property} if !$prp;
+ if (!$prp){
+ $buffer = "<<ERROR<$property>Property not found!>>>\n"
+ }else{
+ $buffer = "<<$property><$prp>>\n";
+ }
+ return $buffer if !$handle;
+ print $handle $buffer;
return 0;
}
}
###
-# Closes any buffered files and clears all data for the parser.
-# TODO 2020-02-13 Under development.
+# The following is a typical example of an log settings property.
#
-sub END {
-
-undef %anons;
-undef %consts;
-undef %mig;
-undef @sql;
-undef @files;
-undef %tables;
-#undef %data;
+# <<@<%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 $attach = join @_; $message .= $attach if $attach;
+ my %log = $self -> collection('%LOG');
+ my $time = DateTime->from_epoch( epoch => time )->strftime('%Y-%m-%d %H:%M:%S.%3N');
+ if($message =~ /^ERROR/){
+ warn $time . " " . $message;
+ }
+ elsif(%log && $log{console}){
+ print $time . " " . $message ."\n"
+ }
+ if(%log && $log{enabled} && $message){
+ my $logfile = $log{file};
+ my $tail_cnt = $log{tail};
+ if($log{tail} && $tail_cnt && int(`tail -n $tail_cnt $logfile | wc -l`)>$tail_cnt-1){
+ use File::ReadBackwards;
+ my $pos = do {
+ my $fh = File::ReadBackwards->new($logfile) or die $!;
+ $fh->readline() for 1..$tail_cnt;
+ $fh->tell()
+ };
+ truncate($logfile, $pos) or die $!;
+
+ }
+ open (my $fh, ">>", $logfile) or die ("$!");
+ print $fh $time . " - " . $message ."\n";
+ close $fh;
+ }
+}
+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;
+ my $time = DateTime->from_epoch( epoch => time )->strftime('%Y-%m-%d %H:%M:%S.%3N');
+ $message = "$time WARNG $message\t".$self->{CNF_CONTENT};
+ if($self->{ENABLE_WARNINGS}){
+ $self -> log($message)
+ }else{
+ cluck $message
+ }
+}
+sub trace {
+ my $self = shift;
+ my $message = shift;
+ my %log = $self -> collection('%LOG');
+ if(%log){
+ $self -> log($message)
+ }else{
+ cluck $message
+ }
+}
+sub dumpENV{
+ foreach (keys(%ENV)){print $_,"=", "\'".$ENV{$_}."\'", "\n"}
}
-### CGI END
+
+sub END {
+undef %ANONS;
+undef @files;
+}
1;
+
+__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.
+ - DATA - CNF scripted delimited data property, having uniform table data rows.
+ - 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.
+ - 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
lifelog.hopto.org / LifeLog.git / commitdiff