From: Will Budic Date: Thu, 3 Jul 2025 07:22:39 +0000 (+1000) Subject: CNFMeta v.2.0 CNFSQL heavy upd. X-Git-Url: https://lifelog.hopto.org/gitweb/?a=commitdiff_plain;h=9c67199d6555c32c50c993e1f98ea9ae19369385;p=PerlCNF.git CNFMeta v.2.0 CNFSQL heavy upd. --- diff --git a/system/modules/CNFMeta.pm b/system/modules/CNFMeta.pm index f4f6964..9239965 100644 --- a/system/modules/CNFMeta.pm +++ b/system/modules/CNFMeta.pm @@ -11,6 +11,7 @@ package CNFMeta; use strict; use warnings; no warnings qw(experimental::signatures); +use constant VERSION => "2.0"; ### # Returns the regular expression for any of the meta constances. @@ -31,16 +32,22 @@ use constant PRIORITY => qr/(\s*\_+PRIORITY\_(\d+)\_+\s*)/o; # ANONYMOUS tag name assigned where name is not given or tagged. use constant ANN => '__ANN__'; +# We lock lookup hashes, in case they change in this package, to protect them, as READONLY. +# Will rise exceptions in outside older code not being updated to use new keys, or trying to modify them. +use Hash::Util qw(lock_hash); ### # Globals, there is possible only four CNF data types. our %CNF_DATA_TYPES;# ^ # % @ $ (default) +# Mapping names of possible information in a CNF table header we avoid use to hardcode header by array index in vode! our %TABLE_HEADER; +# Relationship index mapping between tables. our %REL_IDX; +### BEGIN { -my $cnt =0; foreach(qw{BOOL INT NUMBER DATE TEXT}){$CNF_DATA_TYPES{$_}=++$cnt} - $cnt =0; foreach(qw{COL_NAMES COL_TYPES RELATIONS ID_PRIMARY ID_TYPE T_BODY I_BODY I_VAL S_BODY DB }) - {$TABLE_HEADER{$_}=$cnt++} - $cnt =0; foreach(qw{IDX TABLE COLNAME}) {$REL_IDX{$_}=$cnt++}; +my $cnt =0; foreach(qw{BOOL INT CNFID NUMBER DATE TEXT}){$CNF_DATA_TYPES{$_}=++$cnt} lock_hash(%CNF_DATA_TYPES); + $cnt =0; foreach(qw{COL_NAMES COL_TYPES RELATIONS TABLE_META ID_TYPE ID_PRIMARY T_BODY F_NAMES F_VALUES F_UPDATES F_WHERE DB META_V}) + {$TABLE_HEADER{$_}=$cnt++} lock_hash(%TABLE_HEADER); + $cnt =0; foreach(qw{IDX TABLE COLNAME}) {$REL_IDX{$_}=$cnt++} lock_hash(%REL_IDX); } ### # Global setting for SQL TEXT to CNF _TEXT_ specified data type range. Programmatically changeable. @@ -49,7 +56,7 @@ our $SQL_CNF_VAR_LENGTH = 2024; sub import { my $caller = caller; no strict "refs"; { - # TREE instuction meta. + # TREE instruction meta. *{"${caller}::meta_has_priority"} = sub {return _meta("HAS_PROCESSING_PRIORITY")}; # Schedule to process before the rest in synchronous line of instructions. The lower the priority number, # the higher, no priority is set to 0 same as the sequential scripted order of appearance. @@ -72,11 +79,13 @@ sub import { return 1; } - - our ($INT,$NUM,$BOOL,$TEXT,$DATE,$ID, $CNFID, $INDEX, $AUTO, $REL) = ( - _meta('INT'),_meta('NUM'),_meta('BOOL'),_meta('TEXT'),_meta('DATE'), - _meta('ID'),_meta('CNF_ID'),_meta('CNF_INDEX'),_meta('AUTO'),_meta('REL') - ); +### +# Data base conversion types supported from the CNF side. +### + our ($INT,$NUM,$BOOL,$TEXT,$DATE,$ID, $CNF_ID, $INDEX, $AUTO, $REL) = ( + _meta('INT'),_meta('NUM'),_meta('BOOL'),_meta('TEXT'),_meta('DATE'), + _meta('ID'),_meta('CNF_ID'),_meta('CNF_INDEX'),_meta('AUTO'),_meta('REL') + ); ### # CNF DATA instruction headers can contain extra expected data type meta info. @@ -84,44 +93,59 @@ sub import { # I know, this is making the whole concept a jigsaw puzzle, but it tries also to skip to have # a need for a TABLE instruction in most expected cases. # It is needed to automate creation and validation of most of the SQL based on CNF script provided data. -# For support of database flavours other than SQLite and Postgres,s this would be the starting point to -# to update, as it will be seen as if postgress building has been passed by parser. Good luck! +# For support of database flavours other than SQLite and PostgreSQL, this would be the starting point to +# to update, as it will be seen as if postgresql building has been passed by parser. Good luck! ### sub _metaTranslateDataHeader { my $isPostgreSQL = shift; - my @header; my @array = @_; my @spec; my @rel; - my ($idType,$body,$tins,$vins,$sels,$primary_set,$primary)=('NONE'); + my $isSQLite = !$isPostgreSQL; #for now we default all to postgresSQL sql flavour. + my @array = @_; + my @header; my @spec; my @rel; my @hdr_table_meta; + my ($idType,$body,$t_fld_names,$t_fld_values,$t_fld_updates,$where_id,$primary_set,$primary)=('NONE'); for my $i (0..$#array){ - my $hdr = $array[$i]; - if(not $primary_set and $hdr eq "ID" or $hdr =~ s/$AUTO/""/ei){ - if($isPostgreSQL){ - $body .= "\"$hdr\" INT UNIQUE PRIMARY KEY GENERATED ALWAYS AS IDENTITY,\n"; - }else{ - $body .= "\"$hdr\" INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,\n"; + my $hdr = $array[$i]; my $orig = $hdr; my $isAuto = $hdr =~ s/$AUTO/""/ei; + while($i==0 && $hdr =~ m/^\s*\_/ && $hdr =~ s/(\s*\_+(\w*?)\_+\s*\b)//){ #Headbutt out table based meta. + $hdr_table_meta[@hdr_table_meta] = $2; + } + if(not $primary_set and $hdr eq "ID" or $isAuto){ + if ($isSQLite) { + $body .= + "\"$hdr\" INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,\n"; + if($isAuto) { + $where_id = "\"_rowid_\" = ?"; + $hdr = "_rowid_"; + }else{ + $where_id = "ID = ?"; + } } - # DB provited sequence, you better don't set this when inserting a record. - $spec[$i] = $CNF_DATA_TYPES{INT}; - $primary = $hdr; + else { + $body .= "\"$hdr\" INT UNIQUE PRIMARY KEY GENERATED ALWAYS AS IDENTITY,\n"; + $where_id = "$hdr = ?"; + } + $spec[$i] = $CNF_DATA_TYPES{INT}; + $primary = $hdr; $primary_set = 1; - $idType = 'AUTOINCREMENT' - }elsif($hdr =~ s/$CNFID/""/ei || $i==0 && $hdr eq "ID"){ + $idType = 'AUTOINCREMENT'; + $array[$i] = $hdr; + # A DB provided sequence, you better don't set this when inserting/updating a record. + next + }elsif($hdr =~ s/$CNF_ID/""/ei || $i==0 && $hdr eq "ID"){ #This is where CNF provides the ID uinque int value (which doesn't have to be autonumbered i.e. '#', but must be unique). $body .= "\"$hdr\" INTEGER NOT NULL PRIMARY KEY CHECK (\"$hdr\">0),\n"; - $spec[$i] = $CNF_DATA_TYPES{INT}; + $spec[$i] = $CNF_DATA_TYPES{CNFID}; $primary = $hdr; $primary_set = 1; - $idType = 'CNF_ID' + $idType = 'CNF_ID'; #UPDATE "main"."TASKS" SET "Completed"=? WHERE "_rowid_"='10' + $where_id = "\"$hdr\" = ?"; }elsif($hdr =~ s/$ID/""/ei){ #This is ID prefix to some other data id stored in this table, usually one to one/many relationship. $body .= "\"$hdr\" INTEGER CHECK (\"$hdr\">0),\n"; - $tins .= $hdr . ',';$vins .= "?,"; $spec[$i] = $CNF_DATA_TYPES{INT}; $primary = $idType = 'ID' }elsif($hdr =~ s/$INDEX/""/ei){ # This is where CNF instructs to make a indexed lookup type field, # for inside database fast selecting, hashing, caching and other queries. $body .= "\"$hdr\" varchar(64) NOT NULL PRIMARY KEY,\n"; - $tins .= $hdr . ','; $spec[$i] = $CNF_DATA_TYPES{TEXT}; $idType = 'CNF_INDEX' }elsif($hdr =~ s/$INT/""/ei){ @@ -135,47 +159,49 @@ sub _metaTranslateDataHeader { } $spec[$i] = $CNF_DATA_TYPES{INT}; $body .= "\"$hdr\" INTEGER NOT NULL,\n"; - $tins .= $hdr . ','; $vins .= "?,"; # if($hdr eq "ID" and not $primary_set and $i==0){ # $primary = $idType = 'ID' # } }elsif($hdr =~ s/$NUM/""/ei){ $body .= "\"$hdr\" NOT NULL,\n"; - $tins .= $hdr . ','; $vins .= "?,"; $spec[$i] = $CNF_DATA_TYPES{NUM}; }elsif($hdr =~ s/$BOOL/''/ei){ if($isPostgreSQL){ - $body .= "\"$hdr\" BOOLEAN NOT NULL,\n"; + $body .= "\"$hdr\" BOOLEAN NOT NULL CHECK (\"$hdr\" IN (0, 1)),\n"; }else{ - $body .= "\"$hdr\" BOOLEAN NOT NULL CHECK (\"$hdr\" IN (0, 1)),\n"; + $body .= "\"$hdr\" BOOLEAN NOT NULL,\n"; + } - $tins .= $hdr . ','; $vins .= "?,"; $spec[$i] = $CNF_DATA_TYPES{BOOL}; }elsif($hdr =~ s/$TEXT/""/ei){ $body .= "\"$hdr\" TEXT NOT NULL CHECK (length(\"$hdr\")<=$SQL_CNF_VAR_LENGTH),\n"; - $tins .= $hdr . ','; $vins .= "?,"; $spec[$i] = $CNF_DATA_TYPES{TEXT}; }elsif($hdr =~ s/$DATE/""/ei){ $body .= "\"$hdr\" TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP,\n"; - $tins .= $hdr . ','; $vins .= "?,"; $spec[$i] = $CNF_DATA_TYPES{DATE}; }else{ $body .= "\"$hdr\" TEXT NOT NULL,\n"; - $tins .= $hdr . ','; $vins .= "?,"; - $spec[$i] = $CNF_DATA_TYPES{TEXT};; + $spec[$i] = $CNF_DATA_TYPES{TEXT}; } - $array[$i] = $hdr; $sels .= "$hdr,"; - } - $sels =~ s/,$//; - $body =~ s/,$//; $tins =~ s/,$//; $vins =~ s/,$//; + $array[$i] = $hdr; + $t_fld_names .= "\"$hdr\","; + $t_fld_values .= "?,"; + $t_fld_updates .= "\"$hdr\" = ?," + }#rof + $t_fld_names =~ s/,$//; $t_fld_values =~ s/,$//; $t_fld_updates=~ s/,$//; $body =~ s/,$//; + +#IMPORTANT - Any changes added or removed bellow here still have to be reflected in _MakeTableHeader subroutine. $header[$TABLE_HEADER{ID_TYPE}] = \$idType; $header[$TABLE_HEADER{ID_PRIMARY}] = \$primary; $header[$TABLE_HEADER{T_BODY}] = \$body; - $header[$TABLE_HEADER{I_BODY}] = \$tins; - $header[$TABLE_HEADER{I_VAL}] = \$vins; - $header[$TABLE_HEADER{S_BODY}] = \$sels; + $header[$TABLE_HEADER{F_NAMES}] = \$t_fld_names; + $header[$TABLE_HEADER{F_VALUES}] = \$t_fld_values; + $header[$TABLE_HEADER{F_UPDATES}] = \$t_fld_updates; + $header[$TABLE_HEADER{F_WHERE}] = \$where_id; $header[$TABLE_HEADER{DB}] = $isPostgreSQL ? 'DB_POSTGRESQL' : 'DB_SQLITE'; -return _MakeTableHeader(\@header,\@array,\@spec,\@rel); + $header[$TABLE_HEADER{META_V}] = VERSION; + +return _MakeTableHeader(\@header,\@array,\@spec,\@rel,\@hdr_table_meta); } ### # Table Header builder routine required to be called when header is made or recreated. @@ -183,23 +209,28 @@ return _MakeTableHeader(\@header,\@array,\@spec,\@rel); # It is direct strict ordinal order referenced header array access. So before use this subroutine must be called. # And when header is modified this subroutine also must be modified, otherwise fatal errors, which is good. # -sub _MakeTableHeader{ my ($header,$lbls,$spec,$rel) = @_; +# IMPORTANT - Any changes bellow must be in order of words appearing as in the protected %TABLE_HEADER list. +# +sub _MakeTableHeader{ my ($header,$lbls,$spec,$rel,$hdr_meta) = @_; my @hdr = @$header; return \[ $lbls, $spec, $rel, - $hdr[$TABLE_HEADER{ID_PRIMARY}], + $hdr_meta, $hdr[$TABLE_HEADER{ID_TYPE}], + $hdr[$TABLE_HEADER{ID_PRIMARY}], $hdr[$TABLE_HEADER{T_BODY}], - $hdr[$TABLE_HEADER{I_BODY}], - $hdr[$TABLE_HEADER{I_VAL}], - $hdr[$TABLE_HEADER{S_BODY}], + $hdr[$TABLE_HEADER{F_NAMES}], + $hdr[$TABLE_HEADER{F_VALUES}], + $hdr[$TABLE_HEADER{F_UPDATES}], + $hdr[$TABLE_HEADER{F_WHERE}], $hdr[$TABLE_HEADER{DB}], + $hdr[$TABLE_HEADER{META_V}], ]; } ### -# Resolves if an scalar reference is an array reference or a reference to an array refference.. +# Resolves if an scalar reference is an array reference or a reference to an array reference. # i.e. my @header = CNFMeta::_deRefArray($$table->{header}); is safer and required # when the foolowwing fails -> # my @header = @($$table->{header}}; diff --git a/system/modules/CNFParser.pm b/system/modules/CNFParser.pm index 6feddcf..9a6a07e 100644 --- a/system/modules/CNFParser.pm +++ b/system/modules/CNFParser.pm @@ -9,6 +9,9 @@ use Syntax::Keyword::Try; use Hash::Util qw(lock_hash unlock_hash); use File::ReadBackwards; use File::Copy; +use IO::Handle qw(flush); +use IO::Compress::Xz qw($XzError); +use IO::Uncompress::UnXz qw($UnXzError); require CNFMeta; CNFMeta::import(); require CNFNode; @@ -19,8 +22,9 @@ require CNFDateTime; ##no critic qw(Subroutines::RequireFinalReturn) ##no critic Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions -use constant VERSION => '3.3.4'; -use constant APP_STS => 'APP_SETTINGS'; +use constant VERSION => '3.3.4'; +use constant APP_STS => 'APP_SETTINGS'; +use constant APP_ARGS => 'ARGUMENTS'; our @files; our %lists; our %properties; @@ -46,7 +50,7 @@ our %ANONS; ### our %RESERVED_WORDS = map +($_, 1), qw{ CONST CONSTANT DATA DATE VARIABLE VAR - FILE TABLE TREE INDEX + FILE TABLE TREE INDEX ARGUMENTS VIEW SQL MIGRATE DO LIB PROCESSOR APP_SETTINGS PLUGIN MACRO %LOG INCLUDE INSTRUCTOR }; @@ -105,12 +109,21 @@ sub new { my ($class, $path, $attrs, $del_keys, $self) = @_; $self->{AUTOLOAD_DATA_FILES} =1 if not exists $self->{AUTOLOAD_DATA_FILES}; $self->{CNF_VERSION} = VERSION; #Get's overwritten via parsing. $self->{__DATA__} = {}; + $self->{XZ_STORE} = 0 if not exists $self->{XZ_STORE}; + $self->{STACK_TRACE} = 1 if not exists $self->{STACK_TRACE}; # Enabled by default, to throw stack trace exceptions. undef $SQL; bless $self, $class; $self -> parse($path, undef, $del_keys) if($path); return $self; } # +### +# Create a blank new repository, allowing for default and new dynamic constances to be set. +### +sub blank{ + return new(shift,undef,@_) +} + sub import { my $caller = caller; no strict "refs"; { @@ -168,17 +181,15 @@ sub _isTrue{ return 0 if(not $value); return ($value =~ /1|true|yes|on|t|da/i) ? 1:0 } - - ### # Post parsing instructed special item objects. They have lower priority to Order of appearance and from CNFNodes. ## -package InstructedDataItem { +package InstructedProcessItem { our %counters; sub new { my ($class, $ele, $ins, $val, $aid) = @_; - my $priority; + my $priority; $ele =~ /(\w)/; #<-resets $1... if($val =~ s/$meta_has_priority/""/sexi){ $priority = 2 }elsif($val =~ s/$meta_process_last/""/sexi){ @@ -209,7 +220,6 @@ package InstructedDataItem { } } # - ### # PropertyValueStyle objects must have same rule of how a property body can be scripted for attributes. ## @@ -370,11 +380,10 @@ sub property { my($self, $name) = @_; }else{ return %{$ret} } - } - return + } return } -sub data {return shift->{'__DATA__'}} +sub data {shift()->{'__DATA__'}} sub listDelimit { my ($this, $d , $t)=@_; @@ -460,16 +469,16 @@ sub template { my ($self, $property, %macros) = @_; # #private to parser sub. -sub doInstruction { my ($self,$e,$t,$v) = @_; +sub doInstruction { my ($self,$e,$t,$v,$is_tagged) = @_; my $DO_ENABLED = $self->{'DO_ENABLED'}; my $priority = 4; my $isMetaConst; - if(!$t && !$v && ref($e) eq 'InstructedDataItem'){ + if(!$t && !$v && ref($e) eq 'InstructedProcessItem'){ my $itm = $e; $e = $itm->{ele} . $itm ->{aid}; $t = $itm->{ins}; $v = $itm->{val}; $priority = $itm->{'^'}; } - $t = "" if not defined $t; + $is_tagged = defined($t); $t = $e if not $is_tagged; if($t eq 'CONST' or $t eq 'CONSTANT'){#Single constant with mulit-line value; # It is NOT allowed to overwrite constant. if (not $self->{$e}){ @@ -484,7 +493,7 @@ sub doInstruction { my ($self,$e,$t,$v) = @_; $anechoic->{$e} = $v; } elsif($t eq 'DATA'){ - $self->doDATAInstructions_($e,$v) + $self->doDATAInstructions_($e,$v) }elsif($t eq 'DATE'){ my $isMetaConst = $v =~ s/$meta_const//s; if($v && $v !~ /now|today/i){ @@ -501,9 +510,9 @@ sub doInstruction { my ($self,$e,$t,$v) = @_; }else{ $anechoic->{$e} = $v } - }elsif($t eq 'FILE'){#@TODO Test case this + }elsif($t eq 'FILE'){ $self->doLoadDataFile($e,$v); - }elsif($t eq 'INCLUDE'){ + }elsif($t eq 'INCLUDE'){ if (!$v){ $v=$e }else{ @@ -522,8 +531,7 @@ sub doInstruction { my ($self,$e,$t,$v) = @_; $includes[@includes] = {script=>$v,local=>$CUR_SCRIPT,loaded=>0, prc_last=>$prc_last}; }elsif($t eq 'TREE'){ my $tree = 0; - if( !$v ){ - $v = $e; + if( !$is_tagged){ $e = CNFMeta::ANN(); } if( $v =~ s/($meta_has_priority)/""/ei ){ @@ -540,8 +548,9 @@ sub doInstruction { my ($self,$e,$t,$v) = @_; $instructs{$e} = \$tree; }elsif($t eq 'TABLE'){ # This all have now be late bound and send via the CNFSQL package. since v.2.6 # It is hardly been used. But in the future this might change. - my $type = "NONE"; if ($v =~ 'AUTOINCREMENT'){$type = "AUTOINCREMENT"} - $self->SQL()->createTable($e,$v,$type) } + my $type = "NONE"; if ($v =~ 'AUTOINCREMENT'){$type = "AUTOINCREMENT"} + $self->SQL()->createTable($e,$v,$type) + } elsif($t eq 'INDEX'){ $self->SQL()->createIndex($v)} elsif($t eq 'VIEW'){ SQL()->createView($e,$v)} elsif($t eq 'SQL'){ $self->SQL($e,$v)} @@ -571,7 +580,7 @@ sub doInstruction { my ($self,$e,$t,$v) = @_; chomp $ret; $anechoic->{$e} = $ret; }else{ - $self->warn("Perl DO_ENABLED script evaluation failed to evalute: $e Error: $@"); + $self->warn("Perl DO_ENABLED script evaluation failed to evaluate: $e Error: $@"); $anechoic->{$e} = '<>'; } }else{ @@ -599,26 +608,29 @@ sub doInstruction { my ($self,$e,$t,$v) = @_; } elsif($t eq 'PLUGIN'){ if($DO_ENABLED){ - $instructs{$e} = InstructedDataItem -> new($e, 'PLUGIN', $v); + $instructs{$e} = InstructedProcessItem -> new($e, 'PLUGIN', $v); }else{ - $self->warn("DO_ENABLED is set to false to process following plugin: $e\n") + $self->warn("DO_ENABLED is set to false to process following plugin: $e\n") } } elsif($t eq 'PROCESSOR' && $DO_ENABLED){ if(not $self->registerProcessor($e, $v)){ - CNFParserException->throw("PostParseProcessor Registration Failed for '<<$e<$t>$v>>'!\t") + CNFParserException->throw("PostParseProcessor Registration Failed for '<<$e<$t>$v>>'!\t") } } elsif($t eq 'INSTRUCTOR'){ if(not $self->registerInstructor($e, $v) && $self->{STRICT}){ - CNFParserException->throw("Instruction Registration Failed for '<<$e<$t>$v>>'!\t"); + CNFParserException->throw("Instruction Registration Failed for '<<$e<$t>$v>>'!\t"); } } elsif($t eq 'MACRO'){ - $instructs{$e}= "$v"; #Forcing into an string type by purpose. + $instructs{$e}= "$v"; # Forcing into an string type by purpose. } elsif($t eq APP_STS){ - $self->instructPlugin(InstructedDataItem -> new($e, APP_STS, $v)); + $self->instructPlugin(InstructedProcessItem -> new($e, APP_STS, $v)); + } + elsif($t eq APP_ARGS){ # Rare to encounter, used to merge CNF with what -options have been passed from the command line. + $instructs{$e}= InstructedProcessItem -> new($e, APP_ARGS, $v); #@see uses doPlugin mechanism to handle it further. } elsif(exists $instructors{$t}){ my $result = $instructors{$t}; @@ -632,15 +644,15 @@ sub doInstruction { my ($self,$e,$t,$v) = @_; 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'}){ - $anechoic->{$e} = InstructedDataItem->new($e,$t,$v) - }else{ - $v = $t if not $v; - if($e=~/^\$/){ - $self->{$e} = $v if !$self->{$e}; # Not allowed to overwrite constant. - }else{ - $anechoic->{$e} = $v - } + if($self->{'HAS_EXTENSIONS'}){ + $anechoic->{$e} = InstructedProcessItem->new($e,$t,$v) + }else{ + $v = $t if not $v; + if($e=~/^\$/){ + $self->{$e} = $v if !$self->{$e}; # Not allowed to overwrite constant. + }else{ + $anechoic->{$e} = $v + } } } else{ @@ -667,53 +679,104 @@ sub doLoadDataFile { my ($self,$e,$v)=@_; } return if not _isTrue($self->{AUTOLOAD_DATA_FILES}); # - $self->loadDataFile($e,$path) + $self->loadDataFile($path,$e) } -sub loadDataFile { my ($self,$e,$path,$v,$i)=@_; - 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); - if(@tags>0){ - 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->doDATAInstructions_($e,$v) - } +sub loadDataFile { my ($self,$path,$e,$v,$i)=@_; + + my ($fh,$content); + + if($self->{XZ_STORE} && -f "$path.xz"){ + $fh = IO::Uncompress::UnXz->new("$path.xz") + or CNFParserException->throw(error=>"IO::Uncompress::UnXz failed: $UnXzError",show_trace=>$self->{STACK_TRACE}); + $fh -> read(\$content); + }else{ + open($fh, "<:perlio", $path ) + or CNFParserException->throw(error=>"Can't open $path -> $!",show_trace=>$self->{STACK_TRACE}); + read $fh, $content, -s $fh; + } + close $fh; + # + push @files, $path; + my @tags = ($content =~ m/<<(\w*<(.*?).*?>>)/gs); + if(@tags>0){ + 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=~/^(DATA)>(.*)/){ + $tag = $1; + $v = $2."\n".$v if $2 } - }else{ - $self->doDATAInstructions_($e,$content) + } + if($tag eq 'DATA'){ + $self->doDATAInstructions_($e,$v) + } + } + }else{ + $self->doDATAInstructions_($e,$content) + } + + return \$content; +} +sub writeToDataFile { my ($self, $path, $property, $fh)=@_; + + if($self->{XZ_STORE}){ + $fh = IO::Compress::Xz->new($path.".xz") or CNFParserException->throw("IO::Compress::Xz failed: $XzError") + }else{ + open($fh, ">", $path ) or CNFParserException->throw("Can't open $path -> $!"); + } + + try{ + foreach my $key (sort keys %{$self->{'__DATA__'}}){ + next if ($property && $property ne $key); + my $cnf_tagged = 0; + my $table_spec = ${$self->{__DATA__}{$key}}; + my @head = @{$table_spec -> {header}}; + my @data = @{$table_spec -> {data}}; + foreach my $next(@data){ + my $transition = join '`', @$next; + if(!$cnf_tagged){ + $cnf_tagged = 1; + my $header = join '`', @{ $head[$CNFMeta::TABLE_HEADER{COL_NAMES}] }; + $fh->print( +qq(<<$key __HAS_HEADER__ +$header~ +)) + } + $fh->print ($transition, "~\n"); + } + print $fh->print(">>\n") if($cnf_tagged) } + }catch($e){ + CNFParserException->throw(error=>$e); + } + flush($fh); + close($fh) or CNFParserException->throw("Can't close $path -> $!"); } ## # DATA instructions are not preserved as CNF script values as would be redundant and a waist. # They by default are only META translated into tables for efficiency by data property name. #private sub doDATAInstructions_{ my ($self,$e,$v,$t,$d)=@_; - my $add_as_SQLTable = $v =~ s/${meta('SQL_TABLE')}/""/sexi; + my $add_as_SQLTable = $v =~ s/${meta('SQL_TABLE')}/""/sexi; #Turn property into an SQL Table on server, using the header. my $isPostgreSQL = $v =~ s/${meta('SQL_PostgreSQL')}/""/sexi; my $isAutonumber = $v =~ s/${meta('AUTO_NUMBERED')}|${meta('AUTONUMBER')}/""/sexi; my $isConstant = $v =~ s/$meta_const//s; 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 @hdr; my @rows; my $autonumber = 0; my $hasPreRunRefs =0; my $ref = $self->{__DATA__}{$e}; if($ref){ - $ref = $$ref; + $ref = $$ref; $hasPreRunRefs = 1; @hdr = @{$ref->{header}}; @rows= @{$ref->{data}}; $autonumber = $ref->{auto}; $isAutonumber = 1 if($autonumber || $isAutonumber); @@ -743,7 +806,9 @@ sub doDATAInstructions_{ my ($self,$e,$v,$t,$d)=@_; if($d =~ /^\#(.*)/) {#First is usually ID a number and also '#' signifies number. $d = $1; if(!$d){ - if($isAutonumber){ $d= ++$autonumber }else{$d=0} + if($isAutonumber){ + $d= ++$autonumber + } else{$d=0} } } else{ @@ -752,16 +817,20 @@ sub doDATAInstructions_{ my ($self,$e,$v,$t,$d)=@_; push @a, $d; } } - # By CNF convention ID is assumed to be a header if [0][0] contains it use _HAS_HEADER_ meta to demand that it is from the sccript. - if(!@hdr && $isHeader || $a[0] eq 'ID'){#<--/ + # By CNF convention ID is assumed to be a header if [0][0] contains it use _HAS_HEADER_ meta to demand that it is from the script. + my $tbl_id_spec = $a[0]; + if(!@hdr && $isHeader || $tbl_id_spec eq 'ID'){#<--/ my %MHDR = %CNFMeta::TABLE_HEADER; - my $ptr = CNFMeta::_metaTranslateDataHeader($isPostgreSQL,@a); + my $ptr = CNFMeta::_metaTranslateDataHeader($isPostgreSQL, @a); @hdr = @{$$ptr}; $isHeader = 0; if ($add_as_SQLTable) { - my $idtyp = $hdr[ $MHDR{ID_TYPE} ]; - my $tbody = $hdr[ $MHDR{T_BODY} ]; - $self->SQL()->createTable( $e, $tbody, $idtyp ) + my $idtyp = ${$hdr[$MHDR{ID_TYPE} ]}; + my $ctpys = $hdr[$MHDR{COL_TYPES}]; + my $tbody = ${$hdr[$MHDR{T_BODY} ]}; + my $tmeta = $hdr[$MHDR{TABLE_META}]; + $idtyp = "AUTOINCREMENT" if $tbl_id_spec eq 'ID'; + $self->SQL()->createTable( $e, $tbody, $idtyp, $tmeta ) } my @rel = CNFMeta::_deRefArray($hdr[$MHDR{RELATIONS}]); if(@rel){ @@ -770,8 +839,8 @@ sub doDATAInstructions_{ my ($self,$e,$v,$t,$d)=@_; } } }elsif(scalar @a > 0){ - $isHeader = 0; #autocorrect if _HAS_HEEADER_ header was accidently set. - push @rows, [@a] + $isHeader = 0; #autocorrect if _HAS_HEADER_ header was accidentally set. + push @rows, [@a] if not $hasPreRunRefs; $hasPreRunRefs=0; } } my $ret = {name=>$e,header=>\@hdr,data=>\@rows,auto=>$autonumber}; @@ -782,19 +851,18 @@ sub doDATAInstructions_{ my ($self,$e,$v,$t,$d)=@_; } $self->{__DATA__}{$e} = \$ret } - ### # 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; # We control from here the constances, as we need to unlock them if a previous parse was run. unlock_hash(%$self); - if(not $content){ + if( not $content ){ $cnf_file = $cnf_file -> {path} if ref($cnf_file) eq 'CNFGlobalFile'; - open(my $fh, "<:perlio", $cnf_file ) or die "Can't open $cnf_file -> $!"; + open(my $fh, "<:perlio", $cnf_file ) + or CNFParserException->throw(error=>"Can't open $cnf_file -> $!",show_trace=>$self->{STACK_TRACE}); read $fh, $content, -s $fh; close $fh; my @stat = stat($cnf_file); @@ -810,18 +878,15 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; $self->{CNF_CONTENT} = 'script' } } - $content =~ m/^\!(CNF\s*(\d+\.\d+))/; - my $CNF_VER = $1; my $CNF_VER_SRC = $2; - if (not $CNF_VER){ - $CNF_VER="Undefined!" - }elsif(VERSION =~ m/^(\d+\.\d+)/ && $CNF_VER_SRC > $1){ - $self->warn("CNF Script version is newer, are you using the latest parser version $CNF_VER?"); + my @src_hdr_ver = ($content =~ m/^\!(CNF\s*((\d+\.*\d*)\.*\d*))/m); + if(@src_hdr_ver){ + $self->{CNF_VERSION} = $src_hdr_ver[0]; + $self->warn( + qq(CNF Script version is newer, are you using the script possible required parser version $src_hdr_ver[0]?)) + if(VERSION =~ m/^(\d+\.\d+)/ && $src_hdr_ver[2] > $1) } - $self->{CNF_VERSION} = $CNF_VER; - - my $spc = $content =~ /\n/ ? '(<{2,3}?)(<*.*?>*)(>{2,3})' : '\s*(<{2,3}?)(<*.*?>*?)(>{2,3})\s*$'; - @tags = ($content =~ m/$spc/gms); - + my $spc = $content =~ /\n/ ? '(<{2,3}?)(<*.*?>*)(>{2,3})' : '\s*(<{2,3}?)(<*.*?>*?)(>{2,3})\s*$'; + my @tags = ($content =~ m/$spc/gms); foreach my $tag (@tags){ next if not $tag; next if $tag =~ m/^(>+)|^(<<)/; @@ -856,7 +921,7 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; } } }else{ - doInstruction($self,$v,$t,undef); + doInstruction($self,$t,undef,$v); } }else{ $v =~ s/\s*>$//; @@ -870,15 +935,6 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; }else{ # 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)); - $anechoic->{$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 -> @@ -919,8 +975,8 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; } $v =~ s/\\/>/g;# escaped brackets from v.2.8. - #Do we have an autonumbered list of anons? - #Instructions like DATA can't be autonumbered properties. + # Do we have an auto-numbered list of anons? + # Instruction like DATA can't be auto-numbered anon type properties. if ($e =~ /(.*?)\$\$$/){ $e = $1; my @array = (); @@ -928,10 +984,13 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; @array = @{$lists{$e}}; } if(!$t or $t ne 'DATA'){ - push @array, InstructedDataItem -> new($e, $t, $v); + push @array, InstructedProcessItem -> new($e, $t, $v); $lists{$e} = \@array; next; + }else{ + doInstruction($self,$e,$t,$v) } + }elsif ($e eq '@'){#collection processing. my $isArray = $t=~ m/^@/; # if(!$v && $t =~ m/(.*)>(\s*.*\s*)/gms){ @@ -990,7 +1049,10 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; my $r = $anechoic->{$s}; $r = $self->{$s} if !$r; $r = $instructs{$s} if !$r; - CNFParserException->throw(error=>"Unable to find property for $t.$name -> $find\n",show_trace=>1) if !$r; + CNFParserException->throw( + error=>"Unable to find property for $t.$name -> $find\n", + show_trace=>$self->{STACK_TRACE} + ) if !$r; $value =~ s/\Q$find\E/$r/g; } } @@ -1000,10 +1062,11 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; $properties{$t}=\%hsh; } next; + }elsif(!$t && $e && $v){ + $anechoic->{$e} = $v; + }else{ + doInstruction($self,$e,$t,$v) } - - doInstruction($self,$e,$t,$v) - } } # Do scripted includes first. As these might set properties imported and processed used by the main script. @@ -1024,7 +1087,7 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; doInstruction($self, $itm); } } - undef %InstructedDataItem::counters; + undef %InstructedProcessItem::counters; } ### Do the smart instructions and property linking. @@ -1056,7 +1119,7 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; } } - @items = sort {$a->{'^'} <=> $b->{'^'}} @items; #sort by priority; + @items = sort {$a->{'^'} <=> $b->{'^'}} @items; #sort by priority; my @splice; for my $idx(0..$#items) { my $struct = $items[$idx]; @@ -1066,18 +1129,18 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; }else{ my $priority = $struct-> {'^'}; if($type eq 'CNFNode' && $priority > 0 && $priority < 5){ - $struct->validate() if $self->{ENABLE_WARNINGS}; - if($struct->name() eq CNFMeta::ANN()){ - my $anode = $struct->process($self, $struct->script()); - foreach my $node($$anode->nodes()){ - $anechoic ->{$node->name()} = \$node; + $struct->validate() if $self->{ENABLE_WARNINGS}; + if($struct->name() eq CNFMeta::ANN()){ + my $anode = $struct->process($self, $struct->script()); + foreach my $node($$anode->nodes()){ + $anechoic ->{$node->name()} = \$node; + } + }else{ + $anechoic ->{$struct->name()} = $struct->process($self, $struct->script()); + $self->log("Processed -> ".$struct->name()) if $self->{DEBUG} } - }else{ - $anechoic ->{$struct->name()} = $struct->process($self, $struct->script()); - $self->log("Processed -> ".$struct->name()) if $self->{DEBUG} - } $splice[@splice] = $idx - @splice; - }elsif($type eq 'InstructedDataItem' && $priority > 0 && $priority < 5){ + }elsif($type eq 'InstructedProcessItem' && $priority > 0 && $priority < 5){ my $t = $struct->{ins}; if($t eq 'PLUGIN'){ instructPlugin($self, $struct); @@ -1104,11 +1167,8 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; $anechoic->{$struct->name()} = $struct->process($self, $struct->script()); } $self->log("Processed -> ".$struct->name()) if $self->{DEBUG} - }elsif($type eq 'InstructedDataItem'){ - my $t = $struct->{ins}; - if($t eq 'PLUGIN'){ - instructPlugin($self, $struct); - } + }elsif($type eq 'InstructedProcessItem'){ + instructPlugin($self, $struct); }else{warn "What is -> $struct type:$type ?"} } undef %instructs; @@ -1154,7 +1214,7 @@ sub doInclude { my ($self, $prp_file) = @_; $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. + # As per file processing of instructions is not encapsulated within a included file, but main include or startup script. $IS_IN_INCLUDE_MODE = 1; $self->parse(undef, $content); $IS_IN_INCLUDE_MODE = 0; @@ -1313,7 +1373,78 @@ sub runPostParseProcessors { } } -# +package _ENV{ + my $parser; + our %opt; + our @CLI_ARGS; + our %app_args; + sub new{ my $class = shift; $parser = shift; + my $lag; + foreach my$sn(@ARGV){ + my @tr = ($sn =~ /([-+])+(\w*)|[=](.*)/g); + if(@tr){ + my $tt = $tr[0]; + my $tn = $tr[1]; + my $tv = $tr[2]; + if($tv){ + $CLI_ARGS[@CLI_ARGS] = [$tt.$tn,$tv]; $lag = 0 + }else{ + $CLI_ARGS[@CLI_ARGS] = [$tt.$tn,1]; $lag = 1 + } + }elsif($lag){ + $CLI_ARGS[@CLI_ARGS - 1] = [$CLI_ARGS[@CLI_ARGS - 1][0],$sn]; $lag = 0; + }else{ + $CLI_ARGS[@CLI_ARGS] = [$sn]; + } + } + return bless {},$class; + } + sub merge_args {my ($self, $script) = @_; + my @args = _toArgumentsArray($script); + if(@CLI_ARGS){ + for my $i(0..$#args){ + my $name = $args[$i]; + foreach my $carr(@CLI_ARGS){ + my $cname = @$carr[0]; + my $val = @$carr[1]; + if($cname eq $name){ + $args[$i] = [$name, $val] + } + } + } + } + $parser->anon()->{CNFParser::APP_ARGS()} = \@args; + } + sub _toArgumentsArray{ my $script = shift; + my $ptr = $parser->anon()->{CNFParser::APP_ARGS()}; + my @ret = $ptr ? @$ptr:(); + foreach my $line(split(/\n/,$script)){ + my @pair = ($line=~/\s*([-+_\w\*]*)|\s*[=]\s*(.*)/g); + if(@pair){ + my $name = lc $pair[0]; + my $value = @pair>1?$pair[1]:0; if($value){ + $value =~ s/(\s*\#.*)$//g;#strip comment at the end if any. + $value =~ s/^\s*["']|['"]$//g;#strip quotes + if($name=~/(.*)(\*)$/ && $2){ + $name = $1; + my $link = $value; + $value = $parser->anon($link); + if(!$value){ + $parser->error("Link argument anon not found: $link") + } + } + }else{ + $value = 1 if $name + } + $name =~ s/^--/-/; + $ret[@ret] = [$name, $value] if $name; + }else{ + $parser->log("Unparsable: $line") + } + } + return @ret; + } +} ### # Setup and pass to plugin CNF functionality. @@ -1337,6 +1468,15 @@ sub doPlugin { $plugin->{instructor} = $instructor; return $plugin; } + elsif($instructor eq APP_ARGS){ + my $env = _ENV->new($self); + $env-> merge_args($script); + $plugin->{property} = $instructor; + $plugin->{instructor} = $instructor; + $plugin->{subroutine} = 'merge_args'; + $plugin->setPlugin($env); + return $plugin; + } elsif($pck && $prp && $sub){ ## no critic (RequireBarewordIncludes) require "$pck.pm" if $pck !~ /::/; @@ -1364,9 +1504,6 @@ sub doPlugin { } } -my @arr = [1,2,3]; - - ### # Generic CNF Link utility on this repository. ## @@ -1671,7 +1808,7 @@ __END__ - TREE - Property is a CNFNode tree containing multiple depth nested children nodes. - INCLUDE - Include properties from another file to this repository. - INDEX - SQL related. - - INSTRUCT - Provides custom new anonymous instruction. + - INSTRUCTOR - 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. @@ -1681,8 +1818,11 @@ __END__ 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. + - LIB - Loads dynamically an external Perl package via either path or as a standard module. This is ghosting normal 'use' and 'require' statements. + - DO - Performs a controlled out scope evaluation of an embedded Perl script or execution of a shell system command. This requires the DO_ENABLED constance to be set for the parser. Otherwise, is not enabled by default. - APP_SETTINGS - Provides external expected application settings defaults to the configuration. 1. These are added and processed in place as they appear sequentially in the script. 1. It can be made possible in the future, to meta instruct to run APP_SETTING at the processing or post processing stages of CNF parsing. 2. These can be externally added constance type CNF items if are found missing or not specified in current cnf file or from includes. 3. An application usually obtains its settings object as an CNF property. Decoupling the CNF from handling this, making it abstract to the parser. + - ARGUMENTS - Special case comand line options to CNF anonons as default value/settings arguments and conversions. diff --git a/system/modules/CNFSQL.pm b/system/modules/CNFSQL.pm index 7ee49f8..19cd223 100644 --- a/system/modules/CNFSQL.pm +++ b/system/modules/CNFSQL.pm @@ -13,7 +13,7 @@ use Tie::IxHash; use constant VERSION => '2.1'; -our (%tables_creat_stmts, %tables_id_type, %tables_data_map); +our (%tables_create_stmts, %tables_id_type, %tables_data_map); our %views = (); our %mig = (); our @sql = (); @@ -21,7 +21,6 @@ our @statements; our %schema_tables; my $isPostgreSQL = 0; -my $hasRecords = 0; my $TZ; my %relationships; @@ -30,33 +29,40 @@ sub new { my ($class, $attrs, $self) = @_; $self = \%$attrs; # By convention any tables and views as appearing in the CNF script should in that order also be created. - tie %tables_creat_stmts, "Tie::IxHash"; + tie %tables_create_stmts, "Tie::IxHash"; tie %views, "Tie::IxHash"; bless $self, $class; } +sub tables_data_map{ + return $tables_data_map{shift} +} sub isPostgreSQL{shift; return $isPostgreSQL} ## # Required to be called when using CNF with an database based storage. -# This subrotine is also a good example why using generic driver for SQL is not recomended. +# This subroutine is also a good example why using generic driver for SQL is not recommended. # Various SQL db server flavours meta info is def. handled differently and not updated in them. # # $map - The synch binding of an CNF TABLE to its CNF DATA property, # a header of the DATA instructed property with a meta _SQL_TABLE_ tag is self column resolving # based on ID not requiring this mapping now. To better explain, CNF data can have several data properties, -# with the map we programatically instruct which on is the right one, per various possible tables? +# with the map we pragmatically instruct which on is the right one, per various possible tables? # @TODO 20231018 - Specifications page to be provided with examples for this. # @upd - Constants changed in script updates list. # sub initDatabase { my($self, $db, $do_not_auto_synch, $map, @upd, $st) = @_; +$db->{AutoCommit} = 1; +$db->{RaiseError} = 1; +my $sql_last; #Check and set CNF_CONFIG try{ %schema_tables = (); $do_not_auto_synch = 0 if @upd; - $hasRecords = 0; - $isPostgreSQL = $db-> get_info( 17) eq 'PostgreSQL'; + my $hasRecords = 0; + my $suppress_data_log = $map -> {suppress_data_log}; + $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){ @@ -109,33 +115,30 @@ try{ } $db->commit(); }else{ unless ($do_not_auto_synch){ - - - - my $sel = $db->prepare("SELECT VALUE FROM CNF_CONFIG WHERE NAME LIKE ?;"); - my $upd = $db->prepare("UPDATE CNF_CONFIG SET VALUE = ?, DESCRIPTION = ? WHERE NAME LIKE ?;"); - my $ins = $db->prepare('INSERT INTO CNF_CONFIG VALUES(?,?,?);'); + my $sqlSEL = $db->prepare("SELECT VALUE FROM CNF_CONFIG WHERE NAME LIKE ?;"); + my $sqlUPD = $db->prepare("UPDATE CNF_CONFIG SET VALUE = ?, DESCRIPTION = ? WHERE NAME LIKE ?;"); + my $sqlINS = $db->prepare('INSERT INTO CNF_CONFIG VALUES(?,?,?);'); $db->begin_work(); foreach my $key(sort keys %{$self->{parser}}){ my ($dsc,$val,$ref); $val = $self->{parser}->const($key); $ref = ref($val); if($ref eq 'CNFDateTime'){ - $ref =''; $val = $val -> toDateTimeFormat() + $ref =''; $val = $val -> toDateTimeFormatWithZone() } if($ref eq ''){ - $sel->execute($key); - my @a = $sel->fetchrow_array(); + $sqlSEL->execute($key); + my @a = $sqlSEL->fetchrow_array(); if(@a==0){ my @sp = split '`', $val; if(scalar @sp>1){$val=$sp[0];$dsc=$sp[1];}else{$dsc=""} - $ins->execute($key,$val,$dsc); + $sqlINS->execute($key,$val,$dsc); }elsif(@upd){ foreach my $find(@upd){ if($find eq $key){ my @sp = split '`', $val; if(scalar @sp>1){$val=$sp[0];$dsc=$sp[1];}else{$dsc=""} - $upd->execute($val,$dsc, $key); + $sqlUPD->execute($val,$dsc, $key); last; } } @@ -150,18 +153,20 @@ try{ # and if has been updated dynamically that is good, as this is what we want. # It is of external config. implementation choice. if($map && ($_= %$map{central_schema})){ - # Out of scope us at the moment multiple shema managment requested init. + # Out of scope us at the moment multiple schema management requested init. # So return what is in the database detected only. $self->{parser}->log("CNFParser-> SQL: Initiated database for central_schema: $_\n"); return \%schema_tables; } - foreach my $tbl_stm(keys %tables_creat_stmts){ - if(!$schema_tables{$tbl_stm} && !$schema_tables{uc $tbl_stm}){ - $st = $tables_creat_stmts{$tbl_stm}; - $self->{parser}->log("CNFParser SQL -> $st\n"); + + ### Create required tables if missing. + foreach my $tbl_stm_name(keys %tables_create_stmts){ + if(!$schema_tables{$tbl_stm_name} && !$schema_tables{uc $tbl_stm_name}){ + $st = $tables_create_stmts{$tbl_stm_name}; + $self->{parser}->log("CNFParser SQL -> $st\n") if not $suppress_data_log; try { $db->do($st); - $self->{parser}->log("CNFParser-> Created table: $tbl_stm"); + $self->{parser}->log("CNFParser-> Created table: $tbl_stm_name"); $do_not_auto_synch = 0; }catch{ die "Failed to create:\n$st\nError:$@" @@ -171,154 +176,232 @@ try{ next if $do_not_auto_synch; } } - foreach my $tbl_stm(keys %tables_creat_stmts){ + + ### Update required tables with data. + foreach my $tbl_stm_name(keys %tables_create_stmts){ next if $do_not_auto_synch; - my @table_info; - my $tbl_id_type = $tables_id_type{$tbl_stm}; + #Table info is from the database not CNF! + my @tbl_spec_info; + my $tbl_id_type = $tables_id_type {$tbl_stm_name}; + my $tbl_mapping = $tables_data_map {$tbl_stm_name}; if(isPostgreSQL()){ - $st = lc $tbl_stm; #we lc, silly psql is lower casing meta and case sensitive for internal purposes. + $st = lc $tbl_stm_name; #we lc, silly psql is lower casing meta and case sensitive for internal purposes. $st="select ordinal_position, column_name, data_type from information_schema.columns where table_schema = 'public' and table_name = '$st';"; - $self->{parser}->log("CNFParser-> $st", "\n"); + $self->{parser}->log("CNFParser-> $st", "\n") if not $suppress_data_log; $st = $db->prepare($st); }else{ - $st = $db->prepare("pragma table_info($tbl_stm)"); + $st = $db->prepare("pragma table_info($tbl_stm_name)"); } $st->execute(); while(my @row_info = $st->fetchrow_array()){ $row_info[2] =~ /(\w+)/; - $table_info[@table_info] = [$row_info[1], uc $1 ] + $tbl_spec_info[@tbl_spec_info] = [$row_info[1], uc $1 ] } - my $table = $tbl_stm; my ($sel,$ins,@spec,$q,$qinto); - $table = %$map{$table} if $map && %$map{$table}; + my($table,$sqlSEL,$sqlINS,$sqlUPD,@spec,$q,$fld_names,$fld_values,$fld_updates,$fld_where,$prime_key,$id_type)=($tbl_stm_name); + $table = %$map{$table} if $map && %$map{$table}; $hasRecords = 0; if(ref($table) eq 'ARRAY'){ @spec = @$table; $table = $spec[0]; shift @spec; foreach(@spec){ $q.="\"$_\" == ? and " } $q =~ s/\sand\s$//; - $st="SELECT * FROM $tbl_stm WHERE $q;"; + $st="SELECT * FROM $tbl_stm_name WHERE $q;"; $self->{parser}->log("SQL -> $st"); - $sel = $db -> prepare($st); + $sqlSEL = $db -> prepare($st); }else{ - my $prime_key = getPrimaryKeyColumnNameWherePart($db, $tbl_stm); - $st="SELECT * FROM $tbl_stm WHERE $prime_key"; - $self->{parser}->log("SQL -> $st"); - $sel = $db -> prepare($st); - my @r = $self->selectRecords($db,"select count(*) from $tbl_stm;")->fetchrow_array(); - $hasRecords = 1 if $r[0] > 0 + $prime_key = getPrimaryKeyColumnNameWherePart($db, $tbl_stm_name); + # $st= "SELECT * FROM $tbl_stm_name WHERE $prime_key"; + # $self->{parser}->log("SQL -> $st"); + # $sqlSEL = $db -> prepare($st); + my @r = $self->selectRecords($db,"select count(*) from $tbl_stm_name;")->fetchrow_array(); + $hasRecords = $r[0] + } + my ($data, $data_ptr)= ($self->{parser} -> {'__DATA__'},undef); + if(!$data){ + $self->{parser}->log("CNFParser -> No CNF data collection scanned for $tbl_stm_name\n"); + }else{ + $data_ptr = %$data{$table}; + } + if(!$data_ptr && $self->{data}){ + if(%tables_data_map){ + $data_ptr = %$data{$tables_data_map{$table}}; + if(!$data_ptr){ + $self->{parser} -> error("Invalid data mapping for table $table -> $tables_data_map{$table}") + } + } + $data_ptr = %{$self->{data}}{$table} if !$data_ptr; } - $q = $qinto = ""; my $qa = $tbl_id_type eq 'CNF_INDEX'; foreach(@table_info){ - if($qa || @$_[0] ne 'ID') { - $qinto .="\"@$_[0]\","; - $q.="?," + my (@hdr,@header,@header_cols,@header_types,@rows,$auto_increment); + if($data_ptr){ + no warnings 'once'; + my %MHDR = %CNFMeta::TABLE_HEADER; + @header = CNFMeta::_deRefArray($$data_ptr->{header}); + @header_cols = CNFMeta::_deRefArray($header[$MHDR{COL_NAMES}]); + @header_types = CNFMeta::_deRefArray($header[$MHDR{COL_TYPES}]); + @rows = CNFMeta::_deRefArray($$data_ptr->{data}); + $fld_names = ${$header[$MHDR{F_NAMES}]}; + $fld_values = ${$header[$MHDR{F_VALUES}]}; + $fld_updates = ${$header[$MHDR{F_UPDATES}]}; + $fld_where = ${$header[$MHDR{F_WHERE}]}; + $prime_key = ${$header[$MHDR{ID_PRIMARY}]}; + $id_type = ${$header[$MHDR{ID_TYPE}]}; + $auto_increment=0; + for my $i(0 .. $#header_cols){ + my $h = $header_cols[$i]; + $hdr[@hdr]={'_'=>$h,'i'=>$i, 't'=>$header_types[$i]} } + $self->{parser} ->error("Header not set for table -> $table") if ! @hdr; + }else{ + $self->{parser}->log("CNFParser -> No data collection is available or mapped to $tbl_stm_name\n"); } - $qinto =~ s/,$//; - $q =~ s/,$//; - $ins = $db -> prepare("INSERT INTO $tbl_stm ($qinto)\nVALUES ($q);"); - my $data = $self->{parser} -> {'__DATA__'}; - if($data){ - my $data_prp = %$data{$table}; - if(!$data_prp && $self->{data}){ - if(%tables_data_map){ - $data_prp = %$data{$tables_data_map{$table}}; - if(!$data_prp){ - $self->{parser} ->error("Invalid data mapping for table $table -> $tables_data_map{$table}") - } + + if($tbl_mapping){ + $fld_names = $fld_values = ""; my $qa = $tbl_id_type eq 'CNF_INDEX'; + foreach(@tbl_spec_info){ + my @r= @$_; + if($qa || $tbl_id_type eq 'NONE' ||$r[0] ne 'ID') { + $fld_names .="\"@$_[0]\","; + $fld_values.="?," } - $data_prp = %{$self->{data}}{$table} if !$data_prp; + } + $fld_names =~ s/,$//; + $fld_values=~ s/,$//; + } + + my ($s_sqlSEL, $s_sqlINS, $s_sqlUPD)=( + "SELECT $prime_key, $fld_names FROM $tbl_stm_name WHERE $fld_where", + "INSERT INTO $tbl_stm_name ($fld_names) VALUES ($fld_values);", + "UPDATE $tbl_stm_name SET $fld_updates WHERE $fld_where;" + ); + my %deref_ptp = %$$data_ptr; + $sql_last = $s_sqlSEL; $sqlSEL = $db -> prepare($s_sqlSEL); $deref_ptp{sql_sel} = $s_sqlSEL;$sql_last = ""; + $sql_last = $s_sqlINS; $sqlINS = $db -> prepare($s_sqlINS); $deref_ptp{sql_ins} = $s_sqlINS;$sql_last = ""; + $sql_last = $s_sqlUPD; $sqlUPD = $db -> prepare($s_sqlUPD); $deref_ptp{sql_upd} = $s_sqlUPD;$sql_last = ""; + $self->{parser}->log("sql_sel -> $s_sqlSEL"); + $self->{parser}->log("sql_ins -> $s_sqlINS"); + $self->{parser}->log("sql_upd -> $s_sqlUPD"); + + + $db->begin_work(); + + my ($cnf_id, @ins, @upd); + if($hasRecords){ + $cnf_id = $hasRecords+1 } - if($data_prp){ - my @hdr; - my @header = CNFMeta::_deRefArray($$data_prp->{header}); - @header = CNFMeta::_deRefArray($header[$CNFMeta::TABLE_HEADER{COL_NAMES}]); - 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 -> $table") if ! @hdr; - - $db->begin_work(); - - for my $row_idx (0 .. $#rows){ - my @col = @{$rows[$row_idx]}; - if(@col>0){ - ## - #sel tbl section - if(@spec){ - my @trans = (); - foreach my $name (@spec){ - foreach(@hdr){ + else{ + $cnf_id = 1 + } + for my $row_idx (0 .. $#rows){ + my $isUpdate = 0; my $ptr = $rows[$row_idx]; + my @col; + if(ref($ptr)eq'ARRAY'){@col = @{$rows[$row_idx]}} + else{ @col = @rows } + if(@col>0){ + ## + #sel tbl section + if(@spec){ + my @trans = (); + foreach my $name (@spec){ + foreach(@hdr){ my $hn = $_->{'_'}; my $hi = $_->{'i'}; + my $ht = $_->{'t'}; if($name =~ m/ID/i){ - if($col[$hi]){ - $trans[@trans] = $col[$hi]; - }else{ - $trans[@trans] = $row_idx; # The row index is ID as default on autonumbered ID columns. - } - last + if($col[$hi]){ + $trans[@trans] = $col[$hi]; + }else{ + $trans[@trans] = $row_idx; # The row index is ID as default on auto-numbered ID columns. + } + last }elsif($name =~ m/$hn/i){ - $trans[@trans] = $col[$hi]; - last + $trans[@trans] = $col[$hi]; + last } - } - } - next if @trans && hasEntry($sel, \@trans); - }else{ - next if hasEntry($sel, $row_idx); # ID is assumed autonumbered on by default + } } - ## - my @ins = (); - foreach(@hdr){ - my $hn = $_->{'_'}; - my $hi = $_->{'i'}; - for my $i(0 .. $#table_info){ - if ($table_info[$i][0] =~ m/$hn/i){ - if($table_info[$i][0]=~/ID/i){ - if($col[$hi]){ + next if @trans && hasEntry($sqlSEL, \@trans); + }else{ + if ($hasRecords && hasEntry($sqlSEL, $col[0])){ # ID is assumed auto-numbered on by default + $isUpdate = 1; + } + } + ## + foreach (@hdr) { + my $hn = $_->{'_'}; + my $hi = $_->{'i'}; + my $ht = $_->{'t'}; no warnings 'once'; + TBL_INFO: for my $i ( 0 .. $#tbl_spec_info ) { + if ( $tbl_spec_info[$i][0] =~ m/$hn/i ) { + if ( $ht == $CNFMeta::CNF_DATA_TYPES{CNFID} ) { + $ins[$i] = ++$cnf_id; + } + elsif ( $tbl_spec_info[$i][0] =~ /ID/i ) { + if ( $col[$hi] ) { $ins[$i] = $col[$hi]; - }else{ - $ins[$i] = $row_idx; # The row index is ID as default on autonumbered ID columns. - } - $auto_increment=$i+1 if $tbl_id_type eq 'AUTOINCREMENT'; - }else{ - my $v = $col[$hi]; - if($table_info[$i][1] =~ /TIME/ || $table_info[$i][1] =~ /DATE/){ - $TZ = exists $self->{parser}->{'TZ'} ? $self->{parser}->{'TZ'} : CNFDateTime::DEFAULT_TIME_ZONE() if !$TZ; - if($v && $v !~ /now|today/i){ - 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,$TZ) -> toDateTimeFormat() - }else{ - $v = CNFDateTime->now({TZ=>$TZ}) -> toDateTimeFormat() - } - }elsif($table_info[$i][1] =~ m/^BOOL/){ - $v = CNFParser::_isTrue($v) ?1:0; - } - $ins[$i] = $v } - last; + else { + # The row index is ID as the default on auto-numbered ID columns. + $ins[$i] = $row_idx + } + $auto_increment = $i + 1 if $tbl_id_type =~ m/^AUTO/i; } - } - } - $self->{parser}->log("SQL -> Insert into $tbl_stm -> [". join(',', @ins)."]"); - if($auto_increment){ - $auto_increment--; - splice @ins, $auto_increment, 1 + else { + my $v = $col[$hi]; + if ( $tbl_spec_info[$i][1] =~ /TIME/ + || $tbl_spec_info[$i][1] =~ /DATE/ + || $ht == + $CNFMeta::CNF_DATA_TYPES{DATE} ) + { + $TZ = + exists $self->{parser}->{'TZ'} + ? $self->{parser}->{'TZ'} + : CNFDateTime::DEFAULT_TIME_ZONE() + if !$TZ; + if ( $v && $v !~ /now|today/i ) { + 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, $TZ )->toDateTimeFormatWithZone() + } + else { + $v = CNFDateTime->now( { TZ => $TZ } )->toDateTimeFormatWithZone() + } + } + elsif ( $tbl_spec_info[$i][1] =~ m/^BOOL/ ) + { + $v = CNFParser::_isTrue($v) ? 1 : 0; + } + $ins[$i] = $v; + } + #last TBL_INFO + } } - $ins->execute(@ins); } + + $self->{parser}->log("SQL -> ".($isUpdate?"Update":"Insert"). + " into $tbl_stm_name -> [". join(',', @ins)."]")if not $suppress_data_log; + if($auto_increment){ + $auto_increment--; + splice @ins, $auto_increment, 1 + } + if($isUpdate){ + if($tbl_id_type !~ m/^AUTO/){ + $ins[@ins] = $col[0]; + }else{ + $ins[@ins] = $auto_increment + } + $sqlUPD->execute(@ins) } + else{ + $sqlINS->execute(@ins); + } + undef @ins } - $db->commit() - }else{ - $self->{parser}->log("CNFParser -> No data collection is available or mapped to $tbl_stm\n"); } - }else{ - $self->{parser}->log("CNFParser -> No data collection scanned for $tbl_stm\n"); - } + $db->commit() } @@ -330,11 +413,12 @@ try{ $self->{parser}->log("CNFParser -> Created view: $view") } } - undef %tables_creat_stmts; undef %tables_id_type; + undef %tables_create_stmts; undef %tables_id_type; undef %views; } catch{ - CNFSQLException->throw(error=>$@, show_trace=>1); + $sql_last = "Last SQL statement: $sql_last\n" if $sql_last; + CNFSQLException->throw(error=>$sql_last.$@, show_trace=>1); } return $self->{parser}-> const('$RELEASE_VER'); } @@ -346,32 +430,49 @@ sub _connectDB { }else{ $path = "" } - my $DSN = $source .'dbname='.$path.$store; + my $dsn = $source .'dbname='.$path.$store; try{ - return DBI->connect($DSN, $user, $pass, {AutoCommit => 1, RaiseError => 1, PrintError => 0, show_trace=>1}); + return DBI->connect($dsn, $user, $pass, {AutoCommit => 0, RaiseError => 1, PrintError => 0, show_trace=>1}); }catch{ - die "

Error->$@


DSN: $DSN
"; + die "

Error->$@


DSN: $dsn
"; } } sub _credentialsToArray{ return split '/', shift } -sub createTable { my ($self, $name, $body, $idType) = @_; - if($body =~ s/${CNFMeta::_meta('MAP_TO')}/""/sexi){ - $body =~ m/\s*(\w*)(.*)/gs; - $tables_data_map{$name} = $1; - $body = $2; - } - elsif($body =~ s/${CNFMeta::_meta('MAP_CNF_DB_VIEW')}/""/sexi){ - $body =~ m/\s*(\w*)(.*)/gs; - $tables_data_map{$1} = $2; - $tables_id_type{$name} = $idType; - return; - } - $tables_creat_stmts{$name} = "CREATE TABLE $name(\n$body);"; +sub _tableMetaContains{ + my $table_meta = shift; + my $meta = shift; + foreach(@${table_meta}){ return 1 if $_ eq $meta} + return 0 +} + + +sub createTable { my ($self, $name, $body, $idType, $tbl_meta) = @_; + + if(!$tbl_meta){ + my @hdr_meta; + if($body =~ s/(\s*\_+(\w*?)\_+\s*\b)//){ + $hdr_meta[@hdr_meta] = $2; + } + $tbl_meta = \@hdr_meta + } + if(_tableMetaContains($tbl_meta, 'MAP_TO')){ + $body =~ m/\s*(\w*)(.*)/gs; + $tables_data_map{$name} = $1; + $body = $2; + } + elsif(_tableMetaContains($tbl_meta,'MAP_CNF_DB_VIEW')){ + $body =~ m/\s*(\w*)(.*)/gs; + $tables_data_map{$1} = $2; $tables_id_type{$name} = $idType; + return; + } + $tables_create_stmts{$name} = "CREATE TABLE $name(\n$body);"; + $tables_id_type{$name} = $idType; } + sub createView { my ($self, $name, $body) = @_; $views{$name} = "CREATE VIEW $name AS $body;" } @@ -392,37 +493,36 @@ sub getStatement { my ($self, $name) = @_; return $self->{$name} if exists $self->{$name}; return; } -sub hasEntry{ my ($sel, $uid) = @_; - return 0 if !$hasRecords; +sub hasEntry{ my ($sqlSEL, $uid) = @_; if(ref($uid) eq 'ARRAY'){ - $sel -> execute(@$uid+1) + $sqlSEL -> execute(@$uid+1) }else{ $uid=~s/^["']|['"]$//g; - $sel -> execute($uid+1) + $sqlSEL -> execute($uid+1) } - my @r=$sel->fetchrow_array(); + my @r=$sqlSEL->fetchrow_array(); return scalar(@r); } sub addRelationships{my ($self,$table_name,$column_spec) = @_; $relationships{$table_name} = $column_spec} sub getRelationships{return %relationships} -sub getPrimaryKeyColumnNameWherePart { my ($db,$tbl_stm) = @_; $tbl_stm = lc $tbl_stm; +sub getPrimaryKeyColumnNameWherePart { my ($db,$tbl_stm_name) = @_; $tbl_stm_name = lc $tbl_stm_name; my $sql = $isPostgreSQL ? qq(SELECT a.attname, format_type(a.atttypid, a.atttypmod) AS data_type FROM pg_index i JOIN pg_attribute a ON a.attrelid = i.indrelid AND a.attnum = ANY(i.indkey) -WHERE i.indrelid = '$tbl_stm'::regclass +WHERE i.indrelid = '$tbl_stm_name'::regclass AND i.indisprimary;) : -qq(PRAGMA table_info($tbl_stm);); +qq(PRAGMA table_info($tbl_stm_name);); my $st = $db->prepare($sql); $st->execute(); my @r = $st->fetchrow_array(); if(!@r){ - CNFSQLException->throw(error=> "Table missing or has no Primary Key -> $tbl_stm", show_trace=>1); + CNFSQLException->throw(error=> "Table missing or has no Primary Key -> $tbl_stm_name", show_trace=>1); } if($isPostgreSQL){ return "\"$r[0]\"=?"; @@ -432,7 +532,7 @@ if(!@r){ while(!$r[5]){ @r = $st->fetchrow_array(); if(!@r){ - CNFSQLException->throw(error=> "Table has no Primary Key -> $tbl_stm", show_trace=>1); + CNFSQLException->throw(error=> "Table has no Primary Key -> $tbl_stm_name", show_trace=>1); } } return $r[1]."=?"; @@ -467,7 +567,7 @@ sub updateCNFConfigRecord { } sub selectRecords { - my ($self, $db, $sql) = @_; + my ($self, $db, $sql,$dsn) = @_; if(scalar(@_) < 2){ die "Wrong number of arguments, expecting CNFParser::selectRecords(\$db, \$sql) got Settings::selectRecords('@_').\n"; } @@ -477,13 +577,13 @@ sub selectRecords { $pst->execute(); return $pst; }catch{ - CNFSQLException->throw(error=>"Database error encountered!\n ERROR->$@\n SQL-> $sql DSN:".$db, show_trace=>1); + CNFSQLException->throw(error=>"Database error encountered!\n ERROR->$@ SQL-> $sql DSN:".$dsn, show_trace=>1); } } #@deprecated -sub tableExists { my ($self, $db, $tbl_stm) = @_; +sub tableExists { my ($self, $db, $tbl_stm_name) = @_; try{ - $db->do("select count(*) from $tbl_stm;"); + $db->do("select count(*) from $tbl_stm_name;"); return 1; }catch{} return 0; @@ -510,7 +610,7 @@ return 0; } sub END { -undef %tables_creat_stmts;undef %views; +undef %tables_create_stmts;undef %views; } 1; diff --git a/system/modules/CNFScriptToANSIFormatter.pm b/system/modules/CNFScriptToANSIFormatter.pm new file mode 100644 index 0000000..166d00b --- /dev/null +++ b/system/modules/CNFScriptToANSIFormatter.pm @@ -0,0 +1,37 @@ +package CNFScriptToANSIFormatter; +use v5.38; +use strict; +use warnings; +use constant VERSION => "1.0"; +use Term::ANSIColor qw(:constants colored); +use CNFParser; + +sub _format($reference){ + +my $content = $$reference; +my $result; + +my $spc = $content =~ /\n/ ? '(<{2,3}?)(<*.*?>*)(>{2,3})' : '\s*(<{2,3}?)(<*.*?>*?)(>{2,3})\s*$'; +my @tags = ($content =~ m/$spc/gms); +foreach my $tag (@tags){ + if (not $tag or $tag =~ m/^(>+)|^(<<)/){ + $result .= YELLOW.$tag.RESET; + $result .= "\n" if $1; + } + next if $tag =~ m/^(>+)|^(<<)/; + if($tag =~ m/^<\s*(\w*)\s+(.*?)>*$/gs){ # Original fastest and early format: <<>> + my $t = $1; + my $v = $2; + if(CNFParser::isReservedWord(undef, $t)){ + $t = RED.$t.RESET; + }else{ + $t = WHITE.$t.RESET; + } + $result .= YELLOW."<<".$t." ".$v.YELLOW.">>".RESET; + }else{ + $result .= GREEN.$tag.RESET; + } +} + +return \$result; +} \ No newline at end of file diff --git a/system/modules/DataProcessorPlugin.pm b/system/modules/DataProcessorPlugin.pm index 9fa0523..3938678 100644 --- a/system/modules/DataProcessorPlugin.pm +++ b/system/modules/DataProcessorPlugin.pm @@ -86,7 +86,7 @@ try{ $mod=1; } else{ - warn "Row in row[$i]='$dts' has imporper date format, contents: @row"; + warn "Row in row[$i]='$dts' has improper date format, contents: @row"; } }else{ $row_value =~ s/^\s+|\s+$//gs if $spec_type!=$CNFMeta::CNF_DATA_TYPES{TEXT}; diff --git a/system/modules/DatabaseCentralPlugin.pm b/system/modules/DatabaseCentralPlugin.pm index b609cd6..5dc6191 100644 --- a/system/modules/DatabaseCentralPlugin.pm +++ b/system/modules/DatabaseCentralPlugin.pm @@ -13,17 +13,16 @@ use Time::Piece; use DBI; use Date::Manip; -require CNFDateTime; -require CNFMeta; +require CNFDateTime; require CNFMeta; require CNFSQL; use constant VERSION => '1.1'; -my ($isSQLite,$dsn)=(0,()); +my ($IS_SQLITE,$DSN,$SUPPRESS_DATA_LOG)=(0,(),0); # Error brace strategy is needed for large systems to throw easy to debug possible exceptions. # I know comes from brace for it not to get it, lol. Things I only come up with... my %BRACE_FOR_ERRORS_CANDIDATE; my $CURRENT_BRACE; sub brace{ $CURRENT_BRACE? $BRACE_FOR_ERRORS_CANDIDATE{$CURRENT_BRACE} :""} -# This the meta static CNF DATA table header definittion. +# This the meta static CNF DATA table header definition. our %MHDR = %CNFMeta::TABLE_HEADER; # This is the unique TZ constance the parser (your script) can change at anytime. our $TZ = CNFDateTime::DEFAULT_TIME_ZONE(); @@ -36,18 +35,28 @@ sub new ($class, $plugin){ return bless $settings, $class } -sub centralDBConnect($self, $user, $passw){ - my $datasource = $self->{DBI_SQL_SOURCE}; - die "DBI_SQL_SOURCE not set!" if !$datasource; - my $dbname = $self->{DB}; - die "DB not set!" if !$dbname; - if(!$user and !$passw){ - my $dbcreds = $self->{DB_CREDENTIALS}; - ($user,$passw) = split '/', $dbcreds - } - $isSQLite = $datasource =~ /DBI:SQLite/i; - $dsn = $datasource .'dbname='.$dbname.($isSQLite?".db":""); - return DBI->connect($dsn, $user, $passw, {AutoCommit => 1, RaiseError => 1, PrintError => 0, show_trace=>1}); +sub centralDBConnect($self){ + my ($user,$pass, $datasource, $dbname, $is_auto_commit, $suppress_data_log, $is_raise_error) = + ( CNFSQL::_credentialsToArray( $self->{DB_CREDENTIALS} ), + $self->{DB_SQL_SOURCE}, + $self->{DB}, + $self->{is_auto_commit}, + $self->{suppress_data_log}, + $self->{is_raise_error} + ); + die "DB_SQL_SOURCE not set!" if !$datasource; + die "DB not set!" if !$dbname; + $IS_SQLITE = $datasource =~ /DBI:SQLite/i; $dbname .= '.db' if $IS_SQLITE && $dbname !~ /.db$/; + $DSN = $datasource .'dbname='.$dbname; + $SUPPRESS_DATA_LOG = CNFParser::_isTrue($suppress_data_log); + $is_auto_commit = CNFParser::_isTrue($is_auto_commit); + $is_raise_error = CNFParser::_isTrue($is_raise_error); + $self->{DSN} = $DSN; + $self->{is_sqlite} = $IS_SQLITE; + $self->{is_auto_commit} = $is_auto_commit; + $self->{is_raise_error} = $is_raise_error; + $self->{suppress_data_log} = $SUPPRESS_DATA_LOG; + return DBI->connect($DSN, $user, $pass, {AutoCommit => $is_auto_commit, RaiseError => $is_raise_error, PrintError => 0, show_trace=>1}); } sub executeStatements($self,$parser,$property){ @@ -56,7 +65,7 @@ sub executeStatements($self,$parser,$property){ foreach my $key(%{$parser->SQL()}){ my $sql = $parser->SQL()->{$key}; next if($key eq 'parser'); - $db = centralDBConnect($self,undef,undef) if !$db; + $db = centralDBConnect($self) if !$db; executePropertyStatement($self,$parser,undef,$key,$sql); } }else{ @@ -64,10 +73,10 @@ sub executeStatements($self,$parser,$property){ } } sub executePropertyStatement($self,$parser,$db,$key,$sql){ - $db = centralDBConnect($self,undef,undef) if !$db; - my $pst = $parser->SQL()->selectRecords($db,$sql); + $db = centralDBConnect($self) if !$db; + my $pst = $parser->SQL()->selectRecords($db,$sql,$self->{DSN}); if(not $pst){ - $parser->error("Failed to prepare statment \$sql->".($sql?$sql:"undef")) + $parser->error("Failed to prepare statement \$sql->".($sql?$sql:"undef")) }else{ my (@row,@data); while(my @row = $pst->fetchrow_array()){ @@ -78,7 +87,7 @@ sub executePropertyStatement($self,$parser,$db,$key,$sql){ my $spec = $CNFSQL::tables_data_map{$key}; if($spec){ my @cols = $spec =~ m/\s*([^`~]*)[`~]{0,1}\s*/gm;pop @cols;#<-regexp is special must pop last empty element. - @header = CNFMeta::_metaTranslateDataHeader($isSQLite,@cols); + @header = CNFMeta::_metaTranslateDataHeader($IS_SQLITE,@cols); } my $table = { name=>$key, @@ -99,7 +108,7 @@ try{ $pst->execute(); return $pst }catch{ - DBCentralPluginException->throw(error=>"

Error->$@


DSN: $dsn sql:$sql
"); + DBCentralPluginException->throw(error=>"

Error->$@


DSN: $DSN sql:$sql
"); } } ### @@ -108,7 +117,7 @@ sub main ($self, $parser, $property) { my ($db, $schema, %CNFConfig, $DT_db_access_date); try{ $TZ = $parser->{TZ}; - $db = centralDBConnect($self,undef,undef); + $db = centralDBConnect($self); $DT_db_access_date = CNFDateTime->now($TZ)->stamp(); if(not exists $parser -> {DB_CREATE_DATE} ){ $parser -> {DB_CREATE_DATE} = $DT_db_access_date; @@ -116,10 +125,13 @@ sub main ($self, $parser, $property) { $parser -> {DB_UPDATE_DATE} = $DT_db_access_date; } my @update = ('DB_SYNCH_DATE'); - $schema = $parser -> SQL() -> initDatabase($db,1, {central_schema=>$property},@update); + $schema = $parser -> SQL() -> initDatabase($db, 1, + {central_schema=>$property, + suppress_data_log=>$SUPPRESS_DATA_LOG}, + @update); %CNFConfig = %{$parser -> SQL() -> selectCNFConfigRecords($db)}; }catch{ - DBCentralPluginException->throw(error=>"Error->$@ \nDSN: $dsn"); + DBCentralPluginException->throw(error=>"Error->$@ \nDSN: $DSN"); } my $DT_db_synch_date = $CNFConfig{DB_SYNCH_DATE}; #This date can by synch run updates that are to the db a change. @@ -132,14 +144,14 @@ if($ref eq 'CNFNode'){ my @NodesTable = @{$schema_node -> search('/table/*')}; warn "Not found any 'table/*' path elements for CNF property :". $schema_node->toPath() if not @NodesTable; ### - my $cnf_data = $parser->data(); + my $self_data = $parser->data(); my $table_prefix = $schema_node->{table_prefix}; $table_prefix = $property if !$table_prefix; my $db_synch = CNFParser::_isTrue($schema_node->{DB_SYNCH_WITH_SCRIPT}); my $db_synch_field = $schema_node->{DB_SYNCH_FIELD}; my $db_script_mod_date = $schema_node->{DB_SCRIPT_UPDATE_DATE}; if(!$db_script_mod_date){ - my $cnf_stat = $db_script_mod_date = $parser -> {CNF_STAT}; - $db_script_mod_date = @$cnf_stat[9] if $cnf_stat + my $self_stat = $db_script_mod_date = $parser -> {CNF_STAT}; + $db_script_mod_date = @$self_stat[9] if $self_stat } $db_script_mod_date = CNFDateTime->now({epoch=>$db_script_mod_date, TZ=>$TZ})->stamp() if $db_script_mod_date; @@ -170,7 +182,7 @@ if($ref eq 'CNFNode'){ } @NodesTable = @NodesRel if(@NodesRel); foreach my $tbl(@NodesTable){ - my $table = %$cnf_data{$tbl -> {property}}; + my $table = %$self_data{$tbl -> {property}}; # db_synch type return of 2 means table already exists and has data, if 1 than just was created and new, needs inserting. if( $db_synch = checkCreateTableSQLProcess($self, $parser, \$schema, $db, $table_prefix, $db_synch, $tbl, $table) ){ $db_synch = 3 if($db_script_mod_date && $db_synch == 2 && $db_script_mod_date->{epoch} > $DT_db_update_date->{epoch}); @@ -210,9 +222,10 @@ if($ref eq 'CNFNode'){ my @spec = CNFMeta::_deRefArray($header[$MHDR{COL_TYPES}]); my @rel = CNFMeta::_deRefArray($header[$MHDR{RELATIONS}]); my $idT = CNFMeta::_deRefArray($header[$MHDR{ID_TYPE}]); + my $idP = CNFMeta::_deRefArray($header[$MHDR{ID_PRIMARY}]); ### - # Following is rare to see in code, my (wBudić) forward override conditional mapping algorithm, + # Following is rare to see in code, my (WBudić) 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. It indexes based on the insert statment. # @@ -238,7 +251,7 @@ if($ref eq 'CNFNode'){ } $JJJ++ } - if ($found==0 && $label ne 'ID'){ + if ($found==0 && $label ne 'ID' and $label ne $idP ){ warn "[".$tbl -> toPath()."].[$label] for table -> ".$tbl->{name}." not found data header mapped label." } } @@ -295,7 +308,7 @@ if($ref eq 'CNFNode'){ } } }else{ - if($store_rec_cnt<$#data){ + if($store_rec_cnt<$#data+1){ my @insert = @{_CNFDataToSQLValues(\@idx,\@spec,\@row)}; $CURRENT_BRACE ='sqlInsert'; $dbsTblInsert->execute(@insert); undef $CURRENT_BRACE; } @@ -308,16 +321,15 @@ if($ref eq 'CNFNode'){ } }#rof @data if($db_synch > 1){ - my $mod = @scrypt_synch_inserts; - if($mod){ + foreach (@scrypt_synch_inserts){ my @record = @{$_}; - my @reposition = _findByIDInData($record[0],\@data); + my @reposition = _findByIDInData(\@data, int($record[0])); $data[@data] = \@record; my @insert = @{_CNFDataToSQLValues(\@idx,\@spec,\@reposition)}; $CURRENT_BRACE ='sqlInsert'; $dbsTblInsert->execute(@insert);undef $CURRENT_BRACE; } - } + # else{ # @TODO This loads from store what is missing in scrypt of current @data, for now disabled, as we synch script with store. # $dbsSelectAnyOverID->execute(scalar(@data)) or die $db->errstr; @@ -383,7 +395,7 @@ try{ } } -sub _findByIDInData($id, $data){ +sub _findByIDInData($data,$id){ foreach(@$data){ my @row = CNFMeta::_deRefArray($_); return @row if $row[0] == $id; @@ -459,7 +471,7 @@ sub _CNFDataToSQLValues($idx,$spec,$row) { my $row_value = @$row [$c]; last if $c >= @$row; if($spec_type==$CNFMeta::CNF_DATA_TYPES{DATE}){ - $row_value = $row_value->toDateTimeFormat() + $row_value = $row_value->toDateTimeFormatWithZone() } $insert[$i] = $row_value; } @@ -467,13 +479,13 @@ sub _CNFDataToSQLValues($idx,$spec,$row) { } ### sub checkCreateTableSQLProcess ($self, $parser, $schema, $db, $table_prefix, $db_synch, $node, $table_data) { - my ($name,$property,$cnf_property)=("","",""); + my ($name,$property,$self_property)=("","",""); $name = $node->{name} if $node->{name}; $property = $node->{property}; $name = $property if !$name; - $cnf_property = $node->toPath(); + $self_property = $node->toPath(); if(!$name&&!$property){ - $parser->error("[$cnf_property] Invalid table node encountered, neither name or property attribute specified!") + $parser->error("[$self_property] Invalid table node encountered, neither name or property attribute specified!") } my $automap = CNFParser::_isTrue($node->{automap}); my $table_name = $table_prefix."__".$name; @@ -498,7 +510,7 @@ sub checkCreateTableSQLProcess ($self, $parser, $schema, $db, $table_prefix, $db sub createSQLStatements($self, $parser, $schema,$table_name, $table_data, $node){ my $property = $node->{property}; - my $cnf_property = $node->toPath(); + my $self_property = $node->toPath(); my $automap = CNFParser::_isTrue($node->{automap}); my $sqlCreateTable = "CREATE TABLE $table_name (\n"; my $sqlInsert = "INSERT INTO $table_name ("; @@ -514,21 +526,21 @@ sub createSQLStatements($self, $parser, $schema,$table_name, $table_data, $node) if($automap){ #Column Mapping is based on the node specified schema, which can be different to scripted in order or req. if(!@header){ - $parser->warn("Node property table header in [$cnf_property] for table '$table_name' ". + $parser->warn("Node property table header in [$self_property] for table '$table_name' ". "from repository '$parser->{CNF_CONTENT}' in linked property not valid or set!\n". $node->toScript()); ## Let's try its data first row to examine obtain CNF column defaults? ## This is deep as we need to reset to the translated data header ## in the parsers data property for the table if it is there? my @data = CNFMeta::_deRefArray($$table_data -> {data}); my $ptr = $data[0]; - $ptr = CNFMeta::_metaTranslateDataHeader(!$isSQLite, @{$ptr}); + $ptr = CNFMeta::_metaTranslateDataHeader(!$IS_SQLITE, @{$ptr}); @header = @{$$ptr}; ## Is the new header valid? For example an empty spec is the dreck! if(!CNFMeta::_deRefArray($header[$MHDR{COL_TYPES}])){ - $parser->error("[$cnf_property] -> Node property table header for [$cnf_property] -> $table_name of link -> [$property] is headles and arebitary!"); + $parser->error("[$self_property] -> Node property table header for [$self_property] -> $table_name of link -> [$property] is headles and arebitary!"); return 0; }else{ - $parser->log("Node property table header for [$cnf_property] -> $table_name succesfully resolved."); + $parser->log("Node property table header for [$self_property] -> $table_name succesfully resolved."); } $node -> {reset_header_issued} = \@header; } @@ -536,20 +548,24 @@ sub createSQLStatements($self, $parser, $schema,$table_name, $table_data, $node) my @lbls = CNFMeta::_deRefArray($header[$MHDR{COL_NAMES}]); my @spec = CNFMeta::_deRefArray($header[$MHDR{COL_TYPES}]); my $IDName = ${$header[$MHDR{ID_PRIMARY}]}; + my $IDType = ${$header[$MHDR{ID_TYPE}]}; my $tbody = ${$header[$MHDR{T_BODY}]}; - my $tins = ${$header[$MHDR{I_BODY}]}; - my $vins = ${$header[$MHDR{I_VAL }]}; - my $sels = ${$header[$MHDR{S_BODY}]}; + my $tins = ${$header[$MHDR{F_NAMES}]}; + my $vins = ${$header[$MHDR{F_VALUES}]}; + my $sels = ${$header[$MHDR{F_NAMES}]}; my $db = $header[$MHDR{DB}]; my $isPostgresSQL = $db eq 'DB_POSTGRESQL' ? 1:0; my $upds = ""; my @uflds = split(',',$tins); foreach(@uflds){$upds .= "$_ = ?,"}; - if($isSQLite && $isPostgresSQL){ # This is tricky logic as both can be false. + if($IS_SQLITE && $isPostgresSQL){ # This is tricky logic as both can be false. $parser->error(qq/Current DBI DataSource doesn't match scripted table instruction of $db will revert to set driver [$self->{DBI_SQL_SOURCE} using SQLLite specs./); $isPostgresSQL = 0; } + if($IS_SQLITE && $IDType eq 'AUTOINCREMENT'){ + $sels = "$IDName,$sels"; + } # Do we keep the original CNF Data Header specs, # or shall we become the creator with this scissors algorithm? if($cols && CNFParser::_isTrue($create_table)){ my $body; my @fields; @@ -574,7 +590,7 @@ sub createSQLStatements($self, $parser, $schema,$table_name, $table_data, $node) next; }elsif($v =~ s/^datetime//i){ - if( $isSQLite ){ + if( $IS_SQLITE ){ $v = "TEXT $v" }else{ $v = "TIMESTAMP $v"; @@ -593,8 +609,6 @@ sub createSQLStatements($self, $parser, $schema,$table_name, $table_data, $node) $sqlInsert =~ s/,$//; $body =~ s/,$//; $tbody = $body; } - #@TODO Mapping could be some other column name than the first expected one beside of primary key type. - my $IDType = ${$header[$MHDR{ID_TYPE}]}; if($IDType eq 'NONE' && !$IDName){ foreach my$i(0..$#spec){ if($spec[$i] == $DATA_TYPE{INT} || $spec[$i] == $DATA_TYPE{NUM}){ @@ -604,7 +618,7 @@ sub createSQLStatements($self, $parser, $schema,$table_name, $table_data, $node) $node->{sqlResetTableSeq} = "SELECT MAX($IDName)+1 FROM \"$table_name\"" } if(!$tbody){ - $parser->error("Error node property data link [$cnf_property]-> [$property] tbody not set."); + $parser->error("Error node property data link [$self_property]-> [$property] tbody not set."); return 0 }else{ if(not CNFParser::_isTrue($disable_sql_creation)){ @@ -617,22 +631,22 @@ sub createSQLStatements($self, $parser, $schema,$table_name, $table_data, $node) } }else{ # Automation create sql from the schema node tree mapping not actual data header scripted. Not recomended approcah but here we go! my @columns = @{$node->search('cols/@@')}; - die "[$cnf_property] -> $table_name Not found any 'cols/@@' path elements for CNF node script ->".$node->toScript if not @columns; + die "[$self_property] -> $table_name Not found any 'cols/@@' path elements for CNF node script ->".$node->toScript if not @columns; my($tins,$vins,$upds,$sels,$IDName); if(!@header){ my @data = CNFMeta::_deRefArray($$table_data -> {data}); my $ptr = $data[0]; - $ptr = CNFMeta::_metaTranslateDataHeader(!$isSQLite, @{$ptr}); + $ptr = CNFMeta::_metaTranslateDataHeader(!$IS_SQLITE, @{$ptr}); @header = @{$$ptr}; $node -> {reset_header_issued} = \@header; - $parser->log("[$cnf_property] Processed Data Property.") + $parser->log("[$self_property] Processed Data Property.") } for(my $i=0;$i<@columns;$i++){ my $col = $columns[$i]; my ($n,$v) = ($col->val() =~ m/\s*(.*?)\s+(.*)\s*/); $sels .= "$n,"; if($v =~ /^auto/){ - if( $isSQLite ){ + if( $IS_SQLITE ){ $v = "integer not null primary key autoincrement" }else{ $v = "INT UNIQUE GENERATED ALWAYS AS IDENTITY"; @@ -642,7 +656,7 @@ sub createSQLStatements($self, $parser, $schema,$table_name, $table_data, $node) splice(@columns,$i--,1); }else{ if($v =~ /^datetime/){ - if( $isSQLite ){ + if( $IS_SQLITE ){ $v = "TEXT" }else{ $v = "TIMESTAMP"; @@ -693,13 +707,13 @@ sub getConfigFiles($self, $parser, $property){ our @header = (); $header[$MHDR{ID_TYPE}] = "AUTOINCREMENT"; $header[$MHDR{T_BODY}] ="create table ".uc $property." ID INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, Path varchar(120) NOT NULL, Size NUMBER, Modifeid NUMBER;"; - $header[$MHDR{I_BODY}] = "Path,Size,Lines,Modified"; - $header[$MHDR{I_VAL}] = "?,?,?,?"; - $header[$MHDR{S_BODY}] = "*"; + $header[$MHDR{F_NAMES}] = "Path,Size,Lines,Modified"; + $header[$MHDR{F_VALUES}] = "?,?,?,?"; + $header[$MHDR{F_WHERE}] = "*"; my @files; foreach(@dirs){ - my @list = glob("$_/*.cnf $_/*.config"); + my @list = glob("$_/*.self $_/*.config"); foreach my$fl(@list){ my @stat = stat($fl); my $epoch_timestamp = $stat[9]; diff --git a/tests/libs/LoadTestPackage.pm b/tests/libs/LoadTestPackage.pm index 7136d94..a3105d9 100644 --- a/tests/libs/LoadTestPackage.pm +++ b/tests/libs/LoadTestPackage.pm @@ -4,7 +4,7 @@ use warnings; sub new { my $class = shift; - return bless {'Comming from where?' => 'out of thin air!'},$class + return bless {'Coming from where?' => 'out of thin air!'},$class } sub tester{