From 6a7d38276a90494dfae0030d8dba12e00b0bdd02 Mon Sep 17 00:00:00 2001 From: Will Budic Date: Tue, 25 Jun 2024 00:38:27 +1000 Subject: [PATCH] Release 3.3 DatabaseCentralPlugin and sql and time work. Node shortife parsing finished. --- system/modules/DataProcessorPlugin.pm | 92 +-- .../modules/DataProcessorWorldCitiesPlugin.pm | 5 +- system/modules/DatabaseCentralPlugin.pm | 558 ++++++++++++++++++ system/modules/RSSFeedsPlugin.pm | 52 +- system/modules/ShortLink.pm | 14 +- tests/TestManager.pm | 8 +- tests/dbSQLSetup.cnf | 36 +- tests/testAll.pl | 34 +- tests/testAppSettings.pl | 1 - tests/testCNFMeta.pl | 32 +- tests/testCNFNode.pl | 4 +- tests/testCNFNodeShortiefs.pl | 2 +- tests/testCRONSchedular.pl | 100 ++++ tests/testCartesianProduct.pl | 3 +- tests/testDateInstruction.pl | 14 +- tests/testDoAndLIb.pl | 15 +- tests/testExperimental.pl | 151 ++++- tests/testMarkDownPlugin_MD2HTMLConversion.pl | 29 +- tests/testShortLinks.pl | 11 +- 19 files changed, 948 insertions(+), 213 deletions(-) create mode 100644 system/modules/DatabaseCentralPlugin.pm create mode 100644 tests/testCRONSchedular.pl diff --git a/system/modules/DataProcessorPlugin.pm b/system/modules/DataProcessorPlugin.pm index 05bf6f6..36efc4c 100644 --- a/system/modules/DataProcessorPlugin.pm +++ b/system/modules/DataProcessorPlugin.pm @@ -1,7 +1,7 @@ package DataProcessorPlugin; use strict; -use warnings; +use warnings; no warnings qw(experimental::signatures); use feature qw(signatures); use Scalar::Util qw(looks_like_number); @@ -21,12 +21,13 @@ sub new ($class, $plugin){ } sub process ($self, $parser, $property) { if($property eq '*'){ - foreach(keys %{$parser->data()}){ - my $table = $parser->data()->{$_}; - processProperty($self,$parser,$_); - unless($$table){} + my %data = %{$parser->data()}; + if(%data){ + foreach(keys %data){ + processProperty($self,$parser,$_); + } + return 1 } - return 1 }else{ return processProperty($self,$parser,$property) } @@ -38,40 +39,22 @@ sub processProperty ($self, $parser, $property) { my $table = $parser->data()->{$property}; if(!$table){ $parser->error("DataProcessorPlugin\@Error Table property not found -> $property") - }else{ - my (@hdr,@spec,$mod,$warnc,$knock_out); - my $ref = ref($table); + } + elsif(not $$table->{data_processed}){ try{ - if( $ref ne 'REF'){ - $parser->warn("DataProcessorPlugin\@Error [$property] property table header has not been meta script set!"); - }elsif( $ref ne 'ARRAY'){ - my $ptr = $$table->{header}; - $ref = ref($ptr); - if($ref eq 'REF'){ - $ptr = $$ptr; - } - @hdr=@$ptr; - $ref =ref($hdr[0]); - if($ref eq 'ARRAY'){ - @spec = CNFMeta::_deRefArray($hdr[3]); - }else{ - if ($ref eq ''){ - $parser->warn("DataProcessorPlugin\@Error [$property] property table header is empty!"); - }else{ - @spec = CNFMeta::_deRefArray($hdr[3]); - } - } - - }else{ - die "CNF Table header not set!"; - } + my ($mod,$warnc,$knock_out); + my @header = CNFMeta::_deRefArray($$table->{header}); + my @data = @{$$table->{data}}; + my %mhdr = CNFMeta::TABLE_HEADER(); + my @hdr = CNFMeta::_deRefArray($header[$mhdr{COL_NAMES}]); + my @spec = CNFMeta::_deRefArray($header[$mhdr{COL_TYPES}]); ### my $cols = scalar @spec; my @rows = @{$$table->{data}}; for my $i (0 .. $#rows){ my @row = CNFMeta::_deRefArray($rows[$i]); if(@spec==0){ - #We assume first record is the header if hasn't been meta instructed. + #We assume first record is the header if it hasn't been meta instructed. for my $c (0 .. $#row){ my $row_value = $row[$c]; $row_value =~ m/([\^#%\@\$]|)(.*)/g; my $t = $1; $row_value = $2; @@ -100,12 +83,13 @@ try{ for my $c (0 .. $#row){ my $spec_type = $spec[$c]; my $row_value = $row[$c]; - if(not _matchType($spec_type, $row_value)){ + if(not CNFMeta::_matchType($spec_type, $row_value)){ warn "Row in row[$i]='$row[$i]' doesn't match expect data type, contents: @row"; } elsif($spec_type==$CNFMeta::CNF_DATA_TYPES{DATE}){ my $dts = $row[$c]; - my $dt = UnixDate(ParseDateString($dts), "%Y-%m-%d %T"); + #my $dt = UnixDate(ParseDateString($dts), "%Y-%m-%d %T"); + my $dt = CNFDateTime::_toCNFDate($dts, $parser->{TZ}); if($dt){ $row[$c] = $dt; $mod=1; @@ -137,32 +121,14 @@ try{ }#rof shift @rows if($knock_out); $$table->{data} = \@rows; + $$table->{data_processed} = 1; }catch{ PluginException->throw(error=>"

Error->$@


processProperty('$property')", show_trace=>1); } - } return 1 } -sub _zero_prefix ($times, $val) { - if($times>0){ - return '0'x$times.$val; - }else{ - return $val; - } -} -sub _matchType($type, $val, @rows) { - if ($type == $CNFMeta::CNF_DATA_TYPES{BOOL}){return 1} - elsif($type == $CNFMeta::CNF_DATA_TYPES{INT} || $type == $CNFMeta::CNF_DATA_TYPES{NUMBER} && looks_like_number($val)){return 1} - elsif($type== $CNFMeta::CNF_DATA_TYPES{DATE}){ - if($val=~/\d*\/\d*\/\d*/){return 1} - else{ - return 1; - } - } - elsif($type==$CNFMeta::CNF_DATA_TYPES{TEXT}){return 1} - return 0; -} + ### # Process config data to contain expected fields and data. @@ -209,22 +175,22 @@ sub processOLD ($self, $parser, $property) { # If zero it is presumed ID field, corresponding to row number + 1 is our assumed autonumber. if($row[0] == 0){ my $times = $padding - length($eid+1); - $row[0] = zero_prefix($times,$eid+1); + $row[0] = CNFMeta::_zero_prefix($times,$eid+1); $mod = 1 } if(@row!=$ID_Spec_Size){ warn "Row data[$eid] doesn't match expect column count: $ID_Spec_Size\n @row"; }else{ for my $i (1..$ID_Spec_Size-1){ - if(not _matchType($SPEC[$i], $row[$i])){ - warn "Row in row[$i]='$row[$i]' doesn't match expect data type, contents: @row"; + if(not CNFMeta::_matchType($SPEC[$i], $row[$i])){ + warn "Row in row[$i]='$row[$i]' doesn't match expect data type, contents: @row"; } elsif($SPEC[$i]==2){ - my $dts = $row[$i]; - my $dt = UnixDate(ParseDateString($dts), "%Y-%m-%d %T"); - if($dt){ $row[$i] = $dt; $mod = 1 }else{ - warn "Row in row[$i]='$dts' has imporper date format, contents: @row"; - } + my $dts = $row[$i]; + my $dt = UnixDate(ParseDateString($dts), "%Y-%m-%d %T"); + if($dt){ $row[$i] = $dt; $mod = 1 }else{ + warn "Row in row[$i]='$dts' has imporper date format, contents: @row"; + } }else{ my $v = $row[$i]; $v =~ s/^\s+|\s+$//gs; diff --git a/system/modules/DataProcessorWorldCitiesPlugin.pm b/system/modules/DataProcessorWorldCitiesPlugin.pm index 40a34b1..e425a21 100644 --- a/system/modules/DataProcessorWorldCitiesPlugin.pm +++ b/system/modules/DataProcessorWorldCitiesPlugin.pm @@ -22,8 +22,9 @@ sub process ($self, $parser, $property) { my $table = $parser->data()->{$property}; my @header = @{$$table->{header}}; my @data = @{$$table->{data}}; - my @hdr = @{$header[0]}; - my @spec = @{$header[3]}; + my %mhdr = CNFMeta::TABLE_HEADER(); + my @hdr = CNFMeta::_deRefArray($header[$mhdr{COL_NAMES}]); + my @spec = CNFMeta::_deRefArray($header[$mhdr{COL_TYPES}]); $parser->data()->{$property} = \{ name=>$property, header=>\[\@hdr,"","",\@spec], diff --git a/system/modules/DatabaseCentralPlugin.pm b/system/modules/DatabaseCentralPlugin.pm new file mode 100644 index 0000000..96ad48e --- /dev/null +++ b/system/modules/DatabaseCentralPlugin.pm @@ -0,0 +1,558 @@ +### +# Database Central plugin to convert CNF DATA tables to SQL data store with automation and synchronization. +# It also from script provided values to convert as data to basic CNF value types. Which can be meta directives. +# This operate the premise of an column mapping functionality also, as a mapping via the CNF TREE instruction. +# For speed direct here direct array referencing in a modal automation algorithmic approach is used. +# It implements also atomic's heavily like CNFData table header and CNFMeta for varios possible operations. +### +package DatabaseCentralPlugin; + +use strict; +use warnings; no warnings qw(experimental::signatures); + +use feature qw(signatures); + +use Time::Piece; +use DBI; +use Exception::Class ('PluginException'); +use Syntax::Keyword::Try; +use Clone qw(clone); +use Date::Manip; + +require CNFDateTime; +use constant VERSION => '1.0'; + +my ($isSQLite,$dsn)=(0,()); +our %MHDR = CNFMeta::TABLE_HEADER(); +our $TZ = CNFDateTime::DEFAULT_TIME_ZONE(); + +sub new ($class, $plugin){ + my $settings; + if($plugin){ + $settings = clone $plugin; #clone otherwise will get hijacked with blessings. + } + 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 executeStatements($self,$parser,$property){ + + if($property eq '*'){ + my $db; + foreach my $key(%{$parser->SQL()}){ + my $sql = $parser->SQL()->{$key}; + next if($key eq 'parser'); + $db = centralDBConnect($self,undef,undef) if !$db; + executePropertyStatement($self,$parser,undef,$key,$sql); + } + }else{ + executePropertyStatement($self,$parser,undef,$property,$parser->SQL()->{$property}); + } +} +sub executePropertyStatement($self,$parser,$db,$key,$sql){ + $db = centralDBConnect($self,undef,undef) if !$db; + my $pst = $parser->SQL()->selectRecords($db,$sql); + if(not $pst){ + $parser->error("Failed to prepare statment \$sql->".($sql?$sql:"undef")) + }else{ + my (@row,@data); + while(my @row = $pst->fetchrow_array()){ + $data[@data] = \@row; + } + my @spec; + my @header =[]; + 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); + } + my $table = { + name=>$key, + header=>\@header, + auto=>0, + data=>\@data, + provider=> 'DatabaseCentralPlugin' + + }; + $parser -> data() ->{$key} = \$table if @data; + } +} + +sub doStatement($self,$db, $sql) { +try{ + my $pst = $db->prepare($sql); + return if !$pst; + $pst->execute(); + return $pst +}catch{ + PluginException->throw(error=>"

Error->$@


DSN: $dsn sql:$sql
", show_trace=>1); +} +} +### +sub main ($self, $parser, $property) { + my $schema_node = $parser->anon($property); die "Property of the database schema not available [$property]!" if !$schema_node; + my ($db, $schema, %CNFConfig, $DT_db_access_date); + try{ + $TZ = $parser->{TZ}; + $db = centralDBConnect($self,undef,undef); + $DT_db_access_date = CNFDateTime->now($TZ); + if(not exists $parser -> {DB_CREATE_DATE} ){ + $parser -> {DB_CREATE_DATE} = $DT_db_access_date; + $parser -> {DB_SYNCH_DATE} = $DT_db_access_date; + $parser -> {DB_UPDATE_DATE} = $DT_db_access_date; + } + my @update = ('DB_SYNCH_DATE'); + $schema = $parser -> SQL() -> initDatabase($db,1, {central_schema=>$property},@update); + %CNFConfig = %{$parser -> SQL() -> selectCNFConfigRecords($db)}; + }catch{ + PluginException->throw(error=>"Error->$@ \nDSN: $dsn", show_trace=>1); + } + + my $DT_db_synch_date = $CNFConfig{DB_SYNCH_DATE}; #This date can by synch run updates that are to the db a change. + $DT_db_synch_date = CNFDateTime::_toCNFDate (@$$DT_db_synch_date[0], $TZ) if($DT_db_synch_date); + my $DT_db_update_date = $CNFConfig{DB_UPDATE_DATE}; #This date is by inserts or updates last is been change. + $DT_db_update_date = CNFDateTime::_toCNFDate (@$$DT_db_update_date[0],$TZ) if($DT_db_update_date); + + my $ref = ref($schema_node); + if($ref eq 'CNFNode'){ + my @NodesTable = @{$schema_node -> find('/table/*')}; + warn "Not found any 'table/*' path elements for CNF property :". $schema_node->toPath() if not @NodesTable; +### + my $cnf_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 + } + $db_script_mod_date = CNFDateTime->now({epoch=>$db_script_mod_date, TZ=>$TZ}) if $db_script_mod_date; + + foreach my $tbl(@NodesTable){ + my $table = %$cnf_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($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}); + if($tbl -> {property}){ + # Has the check process resolved the header by any chance for us? + my @header; + if(my $ptr = $tbl -> {reset_header_issued}){ + @header = @$ptr; + $$table->{header} = \@header; + }elsif($table){ + @header = CNFMeta::_deRefArray($$table->{header}); + } + if(@header==0 || @header < 5){ + die "Table data header not established for [".$tbl->toPath()."]->".$tbl -> {property}." length:".scalar @header . + " CNF_CONTENT:" .$parser->{CNF_CONTENT}." has it been meta instructed or DataProcessorPlugin processed?"; + } + my $dbsTblInsert = $db->prepare($tbl -> {sqlInsert}); + my $dbsTblSelect = $db->prepare($tbl -> {sqlSelect}); + my $dbsTblUpdate = $db->prepare($tbl -> {sqlUpdate}); + my $dbsSelectAnyOverID = $db->prepare($tbl -> {sqlSelectAnyOverID}); + my $dbsRecCount = $db->prepare($tbl -> {sqlRecCount}); +### + my @idx = (); + my @map = CNFMeta::_deRefArray($tbl -> {_MAPPING_}); + my @lbls = CNFMeta::_deRefArray($header[$MHDR{COL_NAMES}]); + my @spec = CNFMeta::_deRefArray($header[$MHDR{COL_TYPES}]); + my $idT = CNFMeta::_deRefArray($header[$MHDR{ID_TYPE}]); + ### + # Following is rare to see in code, my (wbudic) forward override conditional mapping algorithm, + # as actual data @row length could be larger to the relative column map, of what we are inserting. + # I know, it looks like a unlocking a magick riddle. It indexes based on the insert statment. + # + if(@lbls){ + MAP_INDEX: + for(my $i=0; $i<@lbls; $i++){ + my $label = $lbls[$i]; + my $JJJ=0; my $found =0; my @set; + foreach (@map){ + if(!@set && ref($_) ne 'ARRAY'){ + @idx = (); for(my $j=0; $j<@lbls; $j++){$idx[$j]=$j} + if ($idT eq 'AUTOINCREMENT'){ + shift @idx + } + last MAP_INDEX; + }else{ + @set = @$_; + } + if($set[0] =~ m/^$label/i){ + $idx[$JJJ] = $i if $set[1] ne 'auto'; + $found=1; + last + } + $JJJ++ + } + if ($found==0 && $label ne 'ID'){ + warn "[".$tbl -> toPath()."].[$label] for table -> ".$tbl->{name}." not found data header mapped label." + } + } + } +### + my @scrypt_synch_inserts; + my @data = @{$$table->{data}}; + $dbsRecCount->execute(); + if(!@data){ + $parser -> warn("Property \[".$tbl->toPath()."] linked data is empty, do you need that?") + }else{ + $db -> begin_work(); + try { + my $store_rec_cnt = $dbsRecCount->fetchrow_array(); + for my $i (0 .. $#data){ + my @row = CNFMeta::_deRefArray($data[$i]); + @row = @{_CNFValTypeTypeRow(\@idx,\@spec,\@row)}; + $data[$i]=\@row; + if($db_synch > 1){ + # Now we need to synch from db to parsers data if anything was stored, + # that is if DATA instruction is of older date only, based on DB_SYNCH_DATE in the DATABASE. + # Which changes on updates, but the script hasn't been touched or is old. + if($DT_db_synch_date && $DT_db_synch_date->{epoch} != $DT_db_update_date->{epoch} ){ + #$db->trace($db->parse_trace_flags("SQL|2")); + my + $synch_field_idx = grep { $db_synch_field eq $lbls[$_] } 0..$#lbls if($db_synch_field); + $dbsTblSelect->execute($row[0]) or die $db->errstr; + if(my @sel = $dbsTblSelect->fetchrow_array()){ + @sel = @{_CNFValTypeTypeRow(\@idx,\@spec,\@sel)}; + DB_SYNCH: + for(my $i=0; $i<@idx; $i++){ + my $c = $idx[$i]; + if( $spec[$c] == $CNFMeta::CNF_DATA_TYPES{DATE} ){ + if($sel[$c]->{epoch} != $row[$c]->{epoch}){ + if($synch_field_idx && $synch_field_idx == $c){ + $scrypt_synch_inserts[@scrypt_synch_inserts] = \@sel; + last DB_SYNCH + } + $row[$c] = $sel[$c] if $db_synch != 3 + } + }elsif($spec[$c] == $CNFMeta::CNF_DATA_TYPES{INT} ){ + if($sel[$c] != $row[$c]){ + $row[$c] = $sel[$c] if $db_synch != 3 + } + }elsif($sel[$c] ne $row[$c]){ + if($synch_field_idx && $synch_field_idx == $c){ + $scrypt_synch_inserts[@scrypt_synch_inserts] = \@sel; + last DB_SYNCH + } + $row[$c] = $sel[$c] if $db_synch != 3 + } + } + }else{ + if($store_rec_cnt<$#data){ + my @insert = @{_CNFDataToSQLValues(\@idx,\@spec,\@row)}; + $dbsTblInsert->execute(@insert); + } + } + next + } + }else{ + my @insert = @{_CNFDataToSQLValues(\@idx,\@spec,\@row)}; + $dbsTblInsert->execute(@insert); + } + }#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); + $data[@data] = \@record; + my @insert = @{_CNFDataToSQLValues(\@idx,\@spec,\@reposition)}; + $dbsTblInsert->execute(@insert); + } + }else{ + $dbsSelectAnyOverID->execute(scalar(@data)) or die $db->errstr; + while(my @sel = $dbsSelectAnyOverID->fetchrow_array()){ + @sel = @{_CNFValTypeTypeRow(\@idx,\@spec,\@sel)}; + $data[@data] = \@sel; + } + } + for my $i(0..$#data){ + my @row = @{$data[$i]}; + @row = @{_CNFDataToSQLValues(\@idx,\@spec,\@row)}; + push @row, $i+1; + $dbsTblUpdate->execute(@row); + } + $parser -> SQL() -> updateCNFConfigRecord($db,'DB_UPDATE_DATE',$db_script_mod_date->toDateTimeFormat()); + } + if($db_synch == 3){ + $parser -> SQL() -> updateCNFConfigRecord($db,'DB_SYNCH_DATE',$DT_db_synch_date->toDateTimeFormat()); + } + $db->commit(); + $$table->{data} = \@data + }catch{ + $db->rollback(); + PluginException->throw( + error=>"DatabaseCentralPlugin\@Error->$@ (Property \[". + $tbl->toPath()."/name='".$tbl->{name}."']", show_trace=>0); + } + } + } + } + }#rof + } + $db->disconnect(); + $parser->data()->{$property} = [$self]; +} +sub findByIDInData($id, $data){ + foreach(@$data){ + my @row = CNFMeta::_deRefArray($_); + return @row if $row[0] == $id; + } +} + +sub _CNFValTypeTypeRow($idx,$spec,$row) { + for(my $i=0; $i<@$idx; $i++){ + my $c = @$idx[$i]; + my $spec_type = @$spec[$c]; + my $row_value = @$row [$c]; + last if $c >= @$row; + if(not CNFMeta::_matchType($spec_type, $row_value)){ + warn "Row in row[$c]='$row_value' doesn't match expect data type, contents: @$row"; + } + elsif($spec_type==$CNFMeta::CNF_DATA_TYPES{DATE}){ + my $dt; + if(lc($row_value) eq 'null' or !$row_value){ + @$row[$c] = CNFDateTime::NULL(); next + }else{ + $dt = UnixDate(ParseDateString($row_value), "%Y-%m-%d %T") + } + if($dt){ + @$row[$c] = CNFDateTime::_toCNFDate ($dt, $TZ) + }else{ + warn "Row in row[$c]='$row_value' has imporper date format, contents: @$row"; + } + }else{ + $row_value =~ s/^\s+|\s+$//gs if $spec_type!=$CNFMeta::CNF_DATA_TYPES{TEXT}; + if($spec_type==$CNFMeta::CNF_DATA_TYPES{BOOL}){ + $row_value = CNFParser::_isTrue($row_value); + } + elsif($spec_type==$CNFMeta::CNF_DATA_TYPES{INT}){ + $row_value = int($row_value) + } + @$row[$c] = $row_value; + } + } + return \@$row; +} +sub _CNFDataToSQLValues($idx,$spec,$row) { + my @insert; + for(my $i=0; $i<@$idx; $i++){ + my $c = @$idx[$i]; + my $spec_type = @$spec[$c]; + my $row_value = @$row [$c]; + last if $c >= @$row; + if($spec_type==$CNFMeta::CNF_DATA_TYPES{DATE}){ + $row_value = $row_value->toDateTimeFormat() + } + $insert[$i] = $row_value; + } + return \@insert; +} + +sub _checkCreateTableSQLProcess ($parser, $schema, $db, $table_prefix, $db_synch, $node, $table_data) { + my ($name,$property,$cnf_property)=("","",""); + $name = $node->{name} if $node->{name}; + $property = $node->{property}; + $name = $property if !$name; + $cnf_property = $node->toPath(); + if(!$name&&!$property){ + $parser->error("[$cnf_property] Invalid table node encountered, neither name or property attribute specified!") + } + my $automap = CNFParser::_isTrue($node->{automap}); + my $table_name = $table_prefix."__".$name; + + if(_createSQLStatements($parser, $schema, $table_name, $table_data, $node)){ + unless (exists $$schema->{$table_name}) { + $db->do($node->{sqlCreateTable}); + $parser->log("DB Issued: Created [$table_name] with -> $node->{sqlCreateTable}"); + return 1; + }elsif($db_synch){ + return 2; + } + } + return 0; +} + +sub _createSQLStatements($parser, $schema,$table_name, $table_data, $node){ + + my $property = $node->{property}; + my $cnf_property = $node->toPath(); + my $automap = CNFParser::_isTrue($node->{automap}); + my $sqlCreateTable = "CREATE TABLE $table_name (\n"; + my $sqlInsert = "INSERT INTO $table_name ("; + my $sqlUpdate = "UPDATE $table_name "; + my $sqlSelect = "SELECT "; + + my @header = CNFMeta::_deRefArray($$table_data -> {header}); #CNFParser resolves and sets this initially + + 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' ". + "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}); + @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!"); + return 0; + }else{ + $parser->log("Node property table header for [$cnf_property] -> $table_name succesfully resolved."); + } + $node -> {reset_header_issued} = \@header; + } + my @lbls = CNFMeta::_deRefArray($header[$MHDR{COL_NAMES}]); + my @spec = CNFMeta::_deRefArray($header[$MHDR{COL_TYPES}]); + my $IDName = ${$header[$MHDR{ID_PRIMARY}]}; + 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 $upds = ""; + my @uflds = split(',',$tins); + foreach(@uflds){$upds .= "$_ = ?,"};$upds =~ s/,$//; + + #@TODO Maping could be some other column name than the first expected one beside of primary key type. + my $IDType = ${$header[$MHDR{ID_TYPE}]}; + if(!$tbody){ + $parser->error("Error node property data link [$cnf_property]-> [$property] tbody not set."); + return 0 + }else{ + $sqlCreateTable ="$sqlCreateTable $tbody );"; + $node->{sqlCreateTable} = $sqlCreateTable; + $node->{sqlInsert} = "$sqlInsert $tins ) VALUES ( $vins );"; + $node->{sqlUpdate} = "$sqlUpdate SET $upds WHERE \"$IDName\" == ?;"; + $node->{sqlSelect} = "$sqlSelect $sels FROM $table_name WHERE \"$IDName\" == ?;"; + $node->{sqlSelectAnyOverID} = "$sqlSelect $sels FROM $table_name WHERE \"$IDName\" > ?;"; + $node->{sqlRecCount} = "SELECT count(*) FROM $table_name;"; + $node->{_MAPPING_} = \@lbls; + return 1 + } + }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->find('cols/@@')}; + die "[$cnf_property] -> $table_name Not found any 'cols/@@' path elements for CNF node script ->".$node->toScript if not @columns; + my($vins,$upds,$sels,$IDName); + if(!@header){ + my @data = CNFMeta::_deRefArray($$table_data -> {data}); + my $ptr = $data[0]; + $ptr = CNFMeta::_metaTranslateDataHeader(!$isSQLite, @{$ptr}); + @header = @{$$ptr}; + $node -> {reset_header_issued} = \@header; + $parser->log("[$cnf_property] Processed Data Property.") + } + my $primary_key; + for(my $i=0;$i<@columns;$i++){ + my $col = $columns[$i]; + my ($n,$v) = ($col->val() =~ /\s*(.*?)\s+(.*)/); + $sels .= "$n,"; + if($v =~ /^auto/){ + if( $isSQLite ){ + $v = "integer primary key autoincrement" + }else{ + $v = "INT UNIQUE GENERATED ALWAYS AS IDENTITY"; + $primary_key = $n; + } + $IDName =$n; + splice(@columns,$i--,1); + }else{ + if($v =~ /^datetime/){ + if( $isSQLite ){ + $v = "TEXT" + }else{ + $v = "TIMESTAMP"; + } + }else{ + $v =~ s/\s*$//; + } + $sqlInsert .= "\"$n\","; $vins .= "?,"; + $upds .= "$n = \"?\","; + $columns[$i] = [$n,$v]; + } + $sqlCreateTable .= "$n $v,\n"; + } + $sqlCreateTable .= "PRIMARY KEY($primary_key)" if $primary_key; + $sqlCreateTable =~ s/,$//; $sqlInsert =~ s/,$//; $vins =~ s/,$//; $sels =~ s/,$//; $upds =~ s/,$//; + $node->{sqlCreateTable} = "$sqlCreateTable);"; + $node->{sqlInsert} = "$sqlInsert ) VALUES ($vins);"; + $node->{sqlUpdate} = "$sqlUpdate SET $upds WHERE \"$IDName\" == ?;"; + $node->{sqlSelect} = "$sqlSelect $sels FROM $table_name WHERE \"$IDName\" == ?;"; + $node->{sqlSelectAnyOverID} = "$sqlSelect $sels FROM $table_name WHERE \"$IDName\" > ?;"; + $node->{sqlRecCount} = "SELECT count(*) FROM $table_name;"; + $node->{_MAPPING_} = \@columns; + return 1; + } +return 0; +} + +sub getConfigFiles($self, $parser, $property){ + my @dirs = $parser->property($property); + my @lbls = ['ID','path','size','lines','modified']; my $cnt=0; #We have to mimic CNF type header entries. + our @spec = [ + $CNFMeta::CNF_DATA_TYPES{INT}, + $CNFMeta::CNF_DATA_TYPES{TEXT}, + $CNFMeta::CNF_DATA_TYPES{NUMBER}, + $CNFMeta::CNF_DATA_TYPES{NUMBER}, + $CNFMeta::CNF_DATA_TYPES{DATE} + ]; + 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}] = "*"; + + my @files; + foreach(@dirs){ + my @list = glob("$_/*.cnf $_/*.config"); + foreach my$fl(@list){ + my @stat = stat($fl); + my $epoch_timestamp = $stat[9]; + my $size = $stat[7]; + my $timestamp = localtime($epoch_timestamp); + my $CNFDate = $timestamp->strftime('%Y-%m-%d %H:%M:%S %Z'); + my $num_lines = do { + open my $fh, '<', $fl or die "Can't open $fl: $!"; + grep { not /^$|^\s*#/ } <$fh>; + }; + push @files, [++$cnt,$fl,$size,$num_lines,$CNFDate] if @list + } + } + # And boom we have an dynamic and valid CNF data table. And with it you can be used to store and synch with now. + $parser-> data() -> {$self->{element}} = \{ + name=>$property, + header=>CNFMeta::_MakeTableHeader(\@header,\@lbls,\@spec), + auto=>0, + data=>\@files + } +} + +1; + +=begin copyright +Programed by : Will Budic +EContactHash : 990MWWLWM8C2MI8K (https://github.com/wbudic/EContactHash.md) +Source : https://github.com/wbudic/PerlCNF.git +Documentation : Specifications_For_CNF_ReadMe.md + This source file is copied and usually placed in a local directory, outside of its repository project. + So it could not be the actual or current version, can vary or has been modiefied for what ever purpose in another project. + Please leave source of origin in this file for future references. +Open Source Code License -> https://github.com/wbudic/PerlCNF/blob/master/ISC_License.md +=cut copyright \ No newline at end of file diff --git a/system/modules/RSSFeedsPlugin.pm b/system/modules/RSSFeedsPlugin.pm index 47051de..d7cf555 100644 --- a/system/modules/RSSFeedsPlugin.pm +++ b/system/modules/RSSFeedsPlugin.pm @@ -6,6 +6,7 @@ no warnings qw(experimental::signatures); use feature qw(signatures); use Scalar::Util qw(looks_like_number); use Syntax::Keyword::Try; +use Exception::Class ('CNFPluginException'); use Clone qw(clone); use Capture::Tiny 'capture_stdout'; use FileHandle; @@ -22,6 +23,8 @@ use constant VERSION => '1.1'; # require CNFDateTime; CNFParser::import(); +our %MHDR = CNFMeta::TABLE_HEADER(); +our $TZ; sub new ($class, $plugin){ my $settings; @@ -43,25 +46,24 @@ sub process ($self, $parser, $property) { $parser->error("RSSFeedsPlugin\@Error Table property not found -> $property"); return } my $cgi = $parser->const('CGI'); - $self->{date} = now(); - my $ptr = $$table->{header}; - my $ref = ref($ptr); - if($ref eq 'REF'){ - $ptr = $$ptr; - } - my @header = @$ptr; - my @data = @{$$table->{data}}; + my @header = @{$$table->{header}}; + my @data = @{$$table->{data}}; + my %mhdr = CNFMeta::TABLE_HEADER(); + my @lbls = CNFMeta::_deRefArray($header[$mhdr{COL_NAMES}]); + my @spec = CNFMeta::_deRefArray($header[$mhdr{COL_TYPES}]); + + $self->{date} = CNFDateTime->now({TZ=>$parser->{TZ}}); + $TZ = $parser->{TZ}; #$parser->log("Header size:".scalar(@header) ); for my $idx (0 .. $#data){ my @col = @{$data[$idx]}; if($idx==0){ $col[5] = 'last_updated'; if(@header){ - my @lbls = CNFMeta::_deRefArray($header[0]); - my @spec = CNFMeta::_deRefArray($header[3]); $lbls[5] = $col[5]; $spec[5] = $CNFMeta::CNF_DATA_TYPES{DATE}; - $$table->{header} = \[\@lbls,$header[1],$header[2],\@spec]; + $col[5] = $self-> {date} -> toTimestamp(); + $$table->{header} = CNFMeta::_MakeTableHeader(\@header,\@lbls,\@spec); } }else{ $col[0] = $idx+1; @@ -89,19 +91,14 @@ sub collectFeeds($self, $parser) { my $property = $self->{property}; my $table = $parser->data()->{$property}; - my $ptr = $$table->{header}; - my $ref = ref($ptr); - if($ref eq 'REF'){ - $ptr = $$ptr; - } - my $page; - my @header = @$ptr; - my $cgi = $parser->const('CGI'); - my $feed = $cgi->param('feed') if $cgi; - my @lbls = CNFMeta::_deRefArray($header[0]); - $ptr = $$table->{data}; - my @data = @$ptr; - my %hdr; + my @data = @{$$table->{data}}; + my $cgi = $parser->const('CGI'); + my $feed = $cgi->param('feed') if $cgi; + my @header = CNFMeta::_deRefArray($$table->{header}); + my @lbls = CNFMeta::_deRefArray($header[$MHDR{COL_NAMES}]); + + + my %hdr; my $page; try{ for(my $i=0;$i<@lbls;$i++){ #<- Column names are set here, if names in script are changed, They must be changed bellow. $hdr{$lbls[$i]} = $i @@ -134,7 +131,8 @@ sub collectFeeds($self, $parser) { $parser-> warn("Feed '$name' bailed to return a CNFNode tree.") } } - }catch{ + }catch($e){ + CNFParserException->throw(error=>$e, show_trace=>1); $parser-> error("RSSFeedsPlugin\@collectFeeds() Error:$@") } $parser->data()->{PAGE} = \$page if $page; @@ -274,7 +272,7 @@ my $buffer = capture_stdout { } } if($convert){ - my $published = CNFDateTime->new()->toTimestamp(); + my $published = CNFDateTime->now({TZ=>$TZ})->toTimestamp(); my $expires = new Date::Manip::Date -> new_date(); $expires->parse("7 business days"); $expires = $expires->printf(CNFDateTime::FORMAT()); my $fnm = $name; $fnm =~ s/[\s|\W]/_/g; @@ -303,7 +301,7 @@ my $buffer = capture_stdout { next } $date = $date->text_content; - $date = CNFDateTime::_toCNFDate($date, $self->{TZ})->toTimestampShort(); + $date = CNFDateTime::_toCNFDate($date, $self->{TZ})->toDateTimeFormat(); if($console){ print "Title : $title\n"; print "Link : $link\n"; diff --git a/system/modules/ShortLink.pm b/system/modules/ShortLink.pm index b621a1d..ea6a329 100644 --- a/system/modules/ShortLink.pm +++ b/system/modules/ShortLink.pm @@ -1,7 +1,9 @@ package ShortLink; -use 5.36.0; -use warnings; use strict; + +use strict; +use warnings; +use feature 'signatures'; use Math::Base::Convert qw(dec b64); @@ -10,18 +12,18 @@ our $CNV = Math::Base::Convert->new(dec, b64); our %LINKS = (); our %PATHS = (); -sub obtain($path){ +sub obtain($path){ if($path){ - return $PATHS{$path} if exists $PATHS{$path}; + return $PATHS{$path} if exists $PATHS{$path}; my $key = $CNV->cnv(++$CNT); - $LINKS{$key} = $path; + $LINKS{$key} = $path; $PATHS{$path} = $key; return $key } die "You f'ed Up!" } -sub existing($path){ +sub existing($path){ return $PATHS{$path}; } diff --git a/tests/TestManager.pm b/tests/TestManager.pm index 82d4811..017a9fc 100644 --- a/tests/TestManager.pm +++ b/tests/TestManager.pm @@ -11,6 +11,7 @@ use Timer::Simple; my $timer = Timer::Simple->new(start => 0, string => 'human'); my $stab = ""; +my $current_test_file; ### # Notice All test are to be run from the project directory. @@ -22,6 +23,7 @@ sub new { $self = bless {test_file=> $test_file,test_cnt=>1,sub_cnt=>0,sub_err=>0}, $class; print BLUE."Running -> ".WHITE."$test_file\n".RESET; $self->{open}=0; + $current_test_file = $test_file; return $self; } @@ -247,7 +249,7 @@ sub dumpTermination { ($error,$file,$lnErr) = ($message =~ m/(.*)\sat\s*(.*)\sline\s(\d*)\./) } }else{ - ($trace,$file,$lnErr) = ($comment =~ m/(.*)\sat\s*(.*)\sline\s(\d*)\.$/); + ($trace,$file,$lnErr) = ($comment =~ m/(.*)\sat\s*(.*)\sline\s(\d*)\.$/); } print BOLD BRIGHT_RED "Test file failed -> $comment"; if($file){ @@ -260,8 +262,8 @@ sub dumpTermination { local $. = $i + 1; my $line = $slurp[$i]; if($. >= $lnErr+1){ - print $comment, RESET.frmln($.).$line; - print "[".$file."] Case $failed->{test_cnt} \n\t".BRIGHT_RED."Failed\@Line".WHITE." $i -> ", $slurp[$i-1].RESET; + print $comment, RESET.frmln($.).$line; $message =~ m/\s*(.*)\n/ if $message; my $cap = $1?$1:""; + print "[".$file."] Case $failed->{test_cnt}\n\t$cap\n\t".BRIGHT_RED."Failed\@Line".WHITE." $i -> ", $slurp[$i-1].RESET."\nFailed test file: $current_test_file"; last }elsif($line=~m/^\s*(\#.*)/){ if( $1 eq '#'){ diff --git a/tests/dbSQLSetup.cnf b/tests/dbSQLSetup.cnf index 1c7147b..1719f76 100644 --- a/tests/dbSQLSetup.cnf +++ b/tests/dbSQLSetup.cnf @@ -1,15 +1,20 @@ !CNF2.9 - ### # Schema structure for tables and views. # This will be used to create the SQL statments by the DatabaseCentralPlugin. -# It is simple and early development and mapping will generically be full for the select and insert statments. +# It is simple and early development and mapping will generically be proper for automated select and insert statments. # it doesn't cover for now, table relationships or constrains. +# The following schema format in a CNF TREE will most definatelly also be rquired +# to obtain access to an unknow or arbitary existing database driver. To bring into an CNF DATA property. +# To do what ever you need with it. Hint, data migration, data display or revalation from one system to another. ### < [table[ name = USERS property: USERS_DATA +# The optional Cols node is array holding node of specific db flavour SQL table body field parameters. +# ID is always special first column in for CNF data but is not an requirment. +# if adding or making an automap to true attribute the Cols node is not required or redundant. [cols[ <@@@@> <@@@@> @@ -54,6 +59,12 @@ ]table] >> +### +# New Data Processor uses a modern table header mapping and conversion by +# synching with an actual SQL database. Its property is always some DB SCHEMA based CNF TREE. +# Which will be used for column mapping and table naming to CNF DATA properties per SQL table. +# This is an uber more advanced version of the DataProcessorPlugin. Can be used in combination with it. +# < DB = test_db_central DB_CREDENTIALS = admin/admin @@ -63,6 +74,13 @@ property : DB_SCHEMA >> +### +# Original data processor converts scripted to expected CNF Data Type. +# This is an step more advanced version of the actual CNFParser provided DATA property. +# This plugin doesn't interact with any database but creates existing column data conversion. +# The wild all '*' as property vealue, will go through all CND DATA entries in the repository and process them. +# Otherwise only do a specified directly property. +# < ___HAS_PROCESSING_PRIORITY___ package : DataProcessorPlugin subroutine : process @@ -74,8 +92,9 @@ ## Sample initial data here, if not of importance can be removed. ## Otherwise if updated here in script or if missing in the db, will be reinserted into it again. ## This behaviour is a feature. As the data or tables can be application specific -## and is part of script to data sychronisation after software upgrades. -## It is recommended if have a large set of data, to put this in a separate script data file, and wire that here instead. +## and is part of a script to data sychronisation after software upgrades. +## It is recommended if have a large set of data, to put this in a separate script data file, +## and include an than wire that in this script instead to an processor plugin. < __HAS_HEADER__ ID`email`name`ID_ADDR~ #`sjulia@smiths.fake.com`Julia Smith`01~ @@ -90,9 +109,9 @@ ID`address`state`city`postcode`country~ ## # We shamelessly reuse same plugin package to nest another subrotine. -# With perl you use actually the same plugin code. Rewired into a new object, all for you by PerlCNF. +# With perl you use actually the same plugin code. Rewired into a new object, all this for you by PerlCNF. # Here we meta mark it HAS_PROCESSING_PRIORITY, as it builds data entries for new table being created. -# For the other plugin instruction, that creates tables and populates them if missing in the database. +# For the DB_SCHEMA property plugin instruction above, that creates tables and populates them if missing in the database. ## << CONFIG_FILES ___HAS_PROCESSING_PRIORITY___ package : DatabaseCentralPlugin @@ -109,8 +128,7 @@ ID`address`state`city`postcode`country~ <<@<@directories> ~/.config ~/.local -~/.vimrc -~/.bashrc +~/.local/share >> ## @@ -142,7 +160,7 @@ ID`address`state`city`postcode`country~ 35`Income `Significant yearly income.~ >> -< __HAS_HEADER__ _CONST__ +< __HAS_HEADER__ _CONST__ __SQL_TABLE__ ID`Name`URL`Description`Expires~ #`Perl Weekly`https://perlweekly.com/perlweekly.rss`A free, once a week e-mail round-up of hand-picked news and articles about Perl. The Perl Weekly ( http://perlweekly.com/ ) is a newsletter including links to blog posts and other news items diff --git a/tests/testAll.pl b/tests/testAll.pl index b48e453..5a0589c 100644 --- a/tests/testAll.pl +++ b/tests/testAll.pl @@ -4,11 +4,12 @@ # Nothing quite other than it, yet does exists. ## use v5.30; -#use warnings; use strict; +#use warnings; use strict; use Syntax::Keyword::Try; use Date::Manip; use Term::ANSIColor qw(:constants); use IPC::Run qw( run timeout ); +use File::Spec; use lib "./local"; use lib "./tests"; @@ -29,7 +30,7 @@ my $SUPRESS_ISSUES = ($ARGV[-1] eq "--display_issues")?0:1; # Notice - All test are to be run from the project directory. # Not in the test directory of this file. # i.e.: perl ./tests/testAll.pl -# If using the PerlLanguageServer, i.e. for debugging, make sure it has started an instance, +# If using the PerlLanguageServer, i.e. for debugging, make sure it has started an instance, # or doesn't have one hanging or already running in some process on the same port. ### print '-'x100, "\n"; @@ -42,10 +43,10 @@ try{ closedir $dh; my ($test_pass, $test_fail, $test_cases, @OUT, %WARN); - - foreach my $file(sort @files) { - - $file = "./tests/$file"; + + foreach my $file(sort @files) { + + $file = "./tests/$file"; my ($in,$output, $warnings); my @perl = ('/usr/bin/env','perl',$file); print "Running->$file\n"; @@ -66,22 +67,23 @@ try{ $test_cases+= $test_ret[0]; }else{ $test_fail++; - my $failed = BOLD. RED. "Failed Test File -> ". WHITE. $file."\n". RESET; - print $failed; + my $failed = BOLD. RED. "Failed Test File -> ". RESET. File::Spec->rel2abs($file) ."\n". RESET; + print $failed; print RED, "\t", $warnings, RESET; $failed[@failed] = $failed; } - + } - foreach(@OUT){ - print $_; + foreach(@OUT){ + print $_; } + print '-'x100, "\n"; if($test_fail){ print BOLD BRIGHT_RED, "HALT! Not all test have passed!\n",BLUE, - "\tNumber of test cases run: $test_cases\n", + "\tNumber of test cases run: $test_cases\n", "\tPassed test count: ", BRIGHT_GREEN, "$test_pass\n", BLUE - "\tFailed test file count: ", BOLD RED,"$test_fail\n",BLUE, + "\tFailed test file count: ", BOLD RED,"$test_fail\n",BLUE, join "",@failed, BOLD WHITE, "Finished with test Suit ->$0\n", RESET; @@ -100,19 +102,19 @@ try{ if(not $SUPRESS_ISSUES && %WARN){ print BOLD YELLOW, "Buddy, sorry to tell you. But you got the following Perl Issues:\n",BLUE; - foreach(keys %WARN){ + foreach(keys %WARN){ my $w = $WARN{$_}; $w=~ s/\s+eval\s\{...\}.*$//gs; $w=~ s/\scalled\sat/\ncalled at/s; print "In file: $_".MAGENTA."\n",$w."\n", BLUE; } - print RESET; + print RESET; }else{ print "To display all encountered issues or warnings, on next run try:\n\tperl tests/testAll.pl --display_issues\n" } print '-'x100, "\n"; } -catch{ +catch{ $manager -> dumpTermination($@) } diff --git a/tests/testAppSettings.pl b/tests/testAppSettings.pl index 0bb1fc6..07eb5c3 100644 --- a/tests/testAppSettings.pl +++ b/tests/testAppSettings.pl @@ -1,5 +1,4 @@ use warnings; use strict; -use 5.36.0; use lib "tests"; use lib "system/modules"; diff --git a/tests/testCNFMeta.pl b/tests/testCNFMeta.pl index 9f59c9e..2817e85 100644 --- a/tests/testCNFMeta.pl +++ b/tests/testCNFMeta.pl @@ -1,5 +1,4 @@ use warnings; use strict; -use 5.36.0; use lib "tests"; use lib "system/modules"; @@ -9,33 +8,33 @@ require CNFMeta; CNFMeta->import(); my $test = TestManager -> new($0); -use Syntax::Keyword::Try; try { +use Syntax::Keyword::Try; try { ### $test->case("Test CNFMeta regexp directly."); my $val = " __PRIORITY_1_____TEST"; my $reg = meta_priority(); my $priority = ($val =~ s/$reg/""/sexi); - $test -> isDefined("\$priority:$1",$2); + $test -> isDefined("\$priority:$1",$2); $test -> isDefined("\$2==$2",$2); - $test -> evaluate("\$val is 'TEST'?",$val,"TEST"); + $test -> evaluate("\$val is 'TEST'?",$val,"TEST"); $reg = meta_has_priority(); $test->subcase("Test -> $reg"); $val ="TEST2 ____HAS_PROCESSING_PRIORITY_______"; $priority = ($val =~ s/$reg/""/sexi); - $test -> isDefined("\$priority:$priority \$val='$val'",$val); - $test -> evaluate("\$val is 'TEST2'?",$val,"TEST2"); + $test -> isDefined("\$priority:$priority \$val='$val'",$val); + $test -> evaluate("\$val is 'TEST2'?",$val,"TEST2"); + # + $test->nextCase(); # - $test->nextCase(); - # $test->case("Test CNFMeta regexp directly."); - + my $parser = CNFParser -> new(undef, {DO_ENABLED=>1})-> parse(undef, qq( < use POSIX qw(strftime); - print strftime "%F", localtime; + print strftime "%F", localtime; >> <return "$^O">> <____PRIORITY_1_`date`>> @@ -43,7 +42,7 @@ use Syntax::Keyword::Try; try { < _PRIORITY_2_ >> < _PRIORITY_1_ - #Should be first property in list, named B otherwise would be first as it goes in a hash of instructs, + #Should be first property in list, named B otherwise would be first as it goes in a hash of instructs, #and all are seen unique names, allowing overides for of annons.. >> @@ -53,21 +52,18 @@ use Syntax::Keyword::Try; try { )); my $props = $parser->anon('PROPERTIES'); - $test -> isDefined("\$props",$props); + $test -> isDefined("\$props",$props); my $json = $parser->JSON()->nodeToJSON($props); - print $$json,"\n"; + print $$json,"\n"; # - $test->nextCase(); + $test->nextCase(); # # $test->done(); # } -catch{ +catch{ $test -> dumpTermination($@); $test->doneFailed(); } - - - \ No newline at end of file diff --git a/tests/testCNFNode.pl b/tests/testCNFNode.pl index 9448f75..2963947 100644 --- a/tests/testCNFNode.pl +++ b/tests/testCNFNode.pl @@ -1,6 +1,6 @@ #!/usr/bin/env perl -use warnings; use strict; use v5.35; - +use warnings; use strict; +use feature 'say'; use lib "tests"; use lib "system/modules"; diff --git a/tests/testCNFNodeShortiefs.pl b/tests/testCNFNodeShortiefs.pl index 0f3a949..13643c7 100644 --- a/tests/testCNFNodeShortiefs.pl +++ b/tests/testCNFNodeShortiefs.pl @@ -1,6 +1,6 @@ #!/usr/bin/env perl use warnings; use strict; -use v5.35; +use feature 'say'; use lib "tests"; use lib "system/modules"; diff --git a/tests/testCRONSchedular.pl b/tests/testCRONSchedular.pl new file mode 100644 index 0000000..c9bd94b --- /dev/null +++ b/tests/testCRONSchedular.pl @@ -0,0 +1,100 @@ +#!/usr/bin/env perl +use warnings; use strict; +use Syntax::Keyword::Try; +use Benchmark; +use File::stat; + +use lib "tests"; +use lib "system/modules"; + +require TestManager; +require CNFParser; +require CNFDateTime; + +my $test = TestManager -> new($0); +my $cnf; + +try{ + + my $fstat = CNFParser::_fetchScriptStat($0); + die $test->failed() if not $cnf = CNFParser->new( undef, + {DO_ENABLED=>1,'%LOG'=>{console=>1},TZ=>'Australia/Sydney', CNF_STAT => $fstat} + ); + $test->case("Passed new instance CNFParser."); + $test->subcase('CNFParser->VERSION is '.CNFParser->VERSION); + + $cnf->parse(undef,qq{ +<< SCHEDULE ___HAS_HEADER__ __AUTO_NUMBERED__ +ID`DUE_DATE __DATE__`NOTIFIED __DATE__`ACTIVE __BOOL__`REACCURING`NOTIFICATION~ +#`2024-06-19 18:30:00``false``Due date and time.~ +#`2024-06-23 8:30:00``true``Tag v.3.2 of ParserCNF.~ +#`2024-06-23 12:30:00``true``Testing 1.~ +#`2024-06-23 14:30:00``true``Testing 2222.~ +#`2024-06-23 14:30:00``true``Testing 3.~ +#`2024-06-23 14:30:00``true``Testing 4.~ +>> +< + DB = test_db_central_schedule + DB_CREDENTIALS = admin/admin + DBI_SQL_SOURCE = DBI:SQLite: + package : DatabaseCentralPlugin + subroutine : main + property : DB_SCHEMA +>>< + + # The DB_SYNCH is per table updating and inserting from CNFData in this script to the store. + # So might not be suitable for multiple table with id relationships or for large data. + # It will synch preserve externally added or updated data, changing here in script auto id expectances. + + DB_SYNCH_WITH_SCRIPT: true + DB_SYNCH_FIELD: DUE_DATE + + [table[ + automap: true + name : SCHEDULE + property: SCHEDULE + [cols[ + <@@< ID auto >@@> + <@@< DUE_DATE datetime not null >@@> + <@@< NOTIFIED datetime >@@> + <@@< ACTIVE boolean default default 1 >@@> + <@@< REACCURING varchar(24) null default 0 >@@> + <@@< NOTIFICATION text not null >@@> + ]cols] + ]table] +>> + + }); + + my $now_dt = CNFDateTime->now(); + my $schedule = $cnf->data()->{SCHEDULE}; + my %map = %{CNFMeta::_obtainColumnMap($schedule)}; + foreach($$schedule->{data}){ + foreach my $row(@$_){ + my $out = join ",", @$row; + if(@$row[$map{ACTIVE}]){ + my $due = @$row[$map{DUE_DATE}]; + if($due->{epoch} < $now_dt-> {epoch}){ + my $message = $due -> toDateTimeFormat() ." ". @$row[$map{NOTIFICATION}]; + $cnf->log($message); + } + } + $cnf->log($out) + } + } + + # + $test->nextCase(); + # + +# +# +$test->done(); +# + + +} +catch{ + $test -> dumpTermination($@); + $test -> doneFailed(); +} diff --git a/tests/testCartesianProduct.pl b/tests/testCartesianProduct.pl index b823515..d3f506c 100644 --- a/tests/testCartesianProduct.pl +++ b/tests/testCartesianProduct.pl @@ -1,6 +1,7 @@ #!/usr/bin/env perl use warnings; use strict; use Syntax::Keyword::Try; +use Math::Cartesian::Product; use lib "tests"; use lib "system/modules"; @@ -8,7 +9,7 @@ use lib "system/modules"; require TestManager; require CNFParser; -use Math::Cartesian::Product; + my $test = TestManager -> new($0); my $cnf; diff --git a/tests/testDateInstruction.pl b/tests/testDateInstruction.pl index bde0f53..8d6640a 100644 --- a/tests/testDateInstruction.pl +++ b/tests/testDateInstruction.pl @@ -35,8 +35,8 @@ try{ # $test->case("Test CNFDateTime Instance."); - die $test->failed() if not my $loca = CNFDateTime -> new(); # <- TODO This will use the default locale as US not the system one, I don't know why yetfailed() if not my $date = CNFDateTime -> new(TZ=>$random_city_in_picked); + die $test->failed() if not my $loca = CNFDateTime -> now(); + die $test->failed() if not my $date = CNFDateTime -> now(TZ=>$random_city_in_picked); my $datetime = $date -> datetime(); $test->isDefined('$datetime',$datetime); $test->passed("For $random_city_in_picked time was set ->".$date -> toSchlong() ); @@ -64,9 +64,9 @@ try{ $test->case("Invalid date format, long, but could be parsable and passable."); $cnf ->parse(undef,q(<01/12/2000 5:30 am>>));#-> Wrong--. Actually for any - my $DandT = $cnf->anon('date_and_time'); # | other country - $test->isDefined('$DandT',$DandT); # | then the US. - $test->evaluate("Is CNFDateTime object?",'CNFDateTime',ref($DandT)); # | + my $DandT = $cnf->anon('date_and_time'); # | other country + $test->isDefined('$DandT',$DandT); # | then the US. + $test->evaluate("Is CNFDateTime object?",'CNFDateTime',ref($DandT)); # | $test->evaluate("Is in us format parsed date?",'2000-01-12 05:30:00.000 AEDT',#<-. $DandT->toTimestamp()); @@ -99,9 +99,11 @@ try{ } $test->case("Test Date Formats"); - $date = $cnf->now(); + $date = CNFDateTime->now(); $test->subcase(&CNFDateTime::FORMAT); $test -> passed($date->datetime() -> strftime(&CNFDateTime::FORMAT)); + $test->subcase(&CNFDateTime::FORMAT_Z); + $test -> passed($date->datetime() -> strftime(&CNFDateTime::FORMAT_Z)); $test->subcase(&CNFDateTime::FORMAT_NANO); $test -> passed($date->datetime() -> strftime(&CNFDateTime::FORMAT_NANO)); $test->subcase(&CNFDateTime::FORMAT_SCHLONG); diff --git a/tests/testDoAndLIb.pl b/tests/testDoAndLIb.pl index 2553bd4..07af364 100644 --- a/tests/testDoAndLIb.pl +++ b/tests/testDoAndLIb.pl @@ -1,5 +1,5 @@ use warnings; use strict; -use 5.36.0; + use lib "tests"; use lib "system/modules"; @@ -8,11 +8,11 @@ require CNFParser; my $test = TestManager -> new($0); -use Syntax::Keyword::Try; try { +use Syntax::Keyword::Try; try { ### $test->case("Test Do."); - + my $parser = CNFParser -> new(undef,{DO_ENABLED=>1}); $parser->parse(undef,qq( @@ -24,7 +24,7 @@ use Syntax::Keyword::Try; try { # LIB instruction is very powerfull, it took me a while to figure out. # It loads the package based on file location or in form of a normal module declaration, which must available via the @INC paths. # Hence LIB instruction must be put at the begining of a config script file to load before a package is used. - # This feature enables you also to specify now from a config file, which packages you use from CNF, + # This feature enables you also to specify now from a config file, which packages you use from CNF, # and not to have to declared them in your perl source with use or require. # <<>> @@ -43,7 +43,7 @@ use Syntax::Keyword::Try; try { # # - $test->nextCase(); + $test->nextCase(); # $test->case("Test Lib loading."); @@ -62,10 +62,7 @@ use Syntax::Keyword::Try; try { $test->done(); # } -catch{ +catch{ $test -> dumpTermination($@); $test->doneFailed(); } - - - \ No newline at end of file diff --git a/tests/testExperimental.pl b/tests/testExperimental.pl index ed26467..0bfa2d8 100644 --- a/tests/testExperimental.pl +++ b/tests/testExperimental.pl @@ -2,9 +2,11 @@ use warnings; use strict; use Syntax::Keyword::Try; use Benchmark; + use lib "tests"; use lib "system/modules"; + require TestManager; require CNFParser; require CNFSQL; @@ -14,31 +16,48 @@ my $cnf; try{ - die $test->failed() if not $cnf = CNFParser->new(); - $test->case("Passed new instance CNFParser."); - $test->subcase('CNFParser->VERSION is '.CNFParser->VERSION); - $cnf -> parse(undef, q( -<>> -<<@<%DualRatioFlourWater - flour = 75% - water = 25% ->> -< __SQL_TABLE__ -__MAP_RELATIONSHIPS_ - Country <-1-1-> Countries@ID - State <-1-1-> States@ID -ID _INT_`Name`Surname`MN`Address`City _INT_`Country _INT_`State _INT_~ -Mike`Hamiltion` +# die $test->failed() if not $cnf = CNFParser->new(); +# $test->case("Passed new instance CNFParser."); +# $test->subcase('CNFParser->VERSION is '.CNFParser->VERSION); +# $cnf -> parse(undef,q( +# <>> +# <<@<%DualRatioFlourWater +# flour = 75% +# water = 25% +# >>)); + +# my $weight = $cnf -> anon('FlourWeight'); $weight =~ s/kg/000/g; +# my %ratio = $cnf -> collection('%DualRatioFlourWater'); + +# # Power of perl will warn, but automatically convert to numeric estimate what want. +# my $rFlour = $ratio{flour}/100; +# my $rWater = $ratio{water}/100; + +# my $waterWeight = ($weight * $rWater); + + +# $test->evaluate("Is expected on ".$cnf -> anon('FlourWeight')." of flour, \$waterWeight == 5oo ml?",500,$waterWeight); + +# ### +# $test -> nextCase(); +# #### + + my $CNF_SCRIPT = qq{ + +< __SQL_TABLE__ _AUTONUMBER_ +ID _AUTO_`Name`Surname`MN`Address`City _INT_`Country _INT_`State _INT_~ +#`Mike`Hamiltion`` Unit 1, 3 Dunlop st.`Sydney`1`1`1~ >> -< __SQL_TABLE__ +< __SQL_TABLE__ _AUTONUMBER_ ID _INT_`Name _TEXT_~ >> -< __SQL_TABLE__ -ID _INT_`Name`Surname`MiddleName`Address`Country`State~ +< +ID _INT_`Name _TEXT_~ #`Australia >> -< __SQL_TABLE__ +//No it is not an joke, some SQL data require this as an table. Otherwise you hardcode views and joins. +< __SQL_TABLE__ _AUTO_NUMBERED_ ID _INT_`Name _TEXT_~ #`NSW~ #`QLD~ @@ -49,23 +68,99 @@ ID _INT_`Name _TEXT_~ #`NT~ >> -< __SQL_TABLE__ +< __SQL_TABLE__ _AUTONUMBER_ +ID _INT_`ID_User _INT_`Note _TEXT_~ +#`1` +Hello World!`~ >> - )); +< + DB = test_db_central + DB_CREDENTIALS = admin/admin + DBI_SQL_SOURCE = DBI:SQLite: + package : DatabaseCentralPlugin + subroutine : main + property : DB_SCHEMA +>> +<>> +<>> + + +## +# Plugin requires this schema to dictate table creation. +# With automap true lucky we cant the plugin resolve the tables creation. +# table_prefix is necessary if using the same DB destination, +# otherwise property name will be used. +# + + + table_prefix : Test_Experimental + _IN_SHORTIFE__ + table __\ + property: Users + automap: yes + table __/ + property: Cities + automap: true + table __\ + property: Countries + automap: on + table __/ + property: States + automap: 1 +>> + +## +# Following is the same inconvetional format. Notice how we untagged it as it isn't used. +# So no commenting out of code in CNF, you just untag. +< + table_prefix: Test_Experimental + [table[ + property: Users + automap: yes + script_synch: true + ]table] + [table[ + property: Cities + automap: true + ]table] + [table[ + property: Countries + automap: on + ]table] + [table[ + property: States + automap: 1 + ]table] + [table[ + name = DB_SCHEMA_DEV_LOG + property: CNF_DB_SCHEMA_LOG + @@> + <@@@@> + >cols> + ]table] +>> +<< CNF_DB_SCHEMA_LOG _SQL_TABLE_ _HAS_HEADER_ +`DATE _DATE_`LOG~ +`2024-05-21`Finished implementation of CNF script to data SQL auto tabulation.~ +``Dynamic date testing. +>> - my $weight = $cnf -> anon('FlourWeight'); $weight =~ s/kg/000/g; - my %ratio = $cnf -> collection('%DualRatioFlourWater'); +}; - # Power of perl will warn, but automatically convert to numeric estimate what want. - my $rFlour = $ratio{flour}/100; - my $rWater = $ratio{water}/100; - my $waterWeight = ($weight * $rWater); +`rm -f test_db_central.db`; + $test->case("Passed new instance CNFParser."); + die $test->failed() + if not $cnf = CNFParser -> new(undef,{DO_ENABLED=>1,DEBUG=>1,'%LOG'=>{console=>1}}) -> + parse(undef,$CNF_SCRIPT); - $test->evaluate("Is expected on ".$cnf -> anon('FlourWeight')." of flour, \$waterWeight == 5oo ml?",500,$waterWeight); + $test->case('Do we have have DB_SYNCH_DATE?'); + my $db_synch_date = $cnf ->{DB_SYNCH_DATE}; + $test -> isDefined("\$db_synch_date",$db_synch_date); # # diff --git a/tests/testMarkDownPlugin_MD2HTMLConversion.pl b/tests/testMarkDownPlugin_MD2HTMLConversion.pl index 53d0fb5..f040bde 100644 --- a/tests/testMarkDownPlugin_MD2HTMLConversion.pl +++ b/tests/testMarkDownPlugin_MD2HTMLConversion.pl @@ -1,5 +1,5 @@ use warnings; use strict; -use 5.36.0; + use lib "tests"; use lib "system/modules/"; @@ -10,7 +10,7 @@ require MarkdownPlugin; my $test = TestManager -> new($0); -use Syntax::Keyword::Try; try { +use Syntax::Keyword::Try; try { ### $test->case("Test instances of parser and MarkDownPlugin."); my $parser = CNFParser -> new(); @@ -35,12 +35,12 @@ use Syntax::Keyword::Try; try { sub static_test_sub { my $node = shift; if($node){ - $test->passed(qq(Call to static_test_sub(.)-> Node [$node->name()] = $node->val())) + $test->passed(qq(Call to static_test_sub(.)-> Node [$node->name()] = $node->val())) }else{ print $test->faled (qq(Call to static_test_sub(.)-> called withouth passing a node)) } } - + my $plugin = MarkdownPlugin -> new({Language=>'English',DateFormat=>'US'}); $plugin->convert($parser,'test'); @@ -61,7 +61,7 @@ use Syntax::Keyword::Try; try { } } # - $test->nextCase(); + $test->nextCase(); # ### @@ -74,13 +74,13 @@ use Syntax::Keyword::Try; try { ['<value>>', q(<<anon>value>>)], ['<value>>', q(<<anon<instruction>value>>)], ['<>', q(<<CONST value>>)], - - + + ); -#$a-><<<anon value>>>, -#$b-><<<anon  value>>> +#$a-><<<anon value>>>, +#$b-><<<anon  value>>> foreach (@cases){ @@ -90,20 +90,17 @@ use Syntax::Keyword::Try; try { $test->isDefined($case[0],$html); say $test->failed("$case[0] CNF format has not properly converted!") if $html !~ /^evaluate($case[0],$html,$case[1]); - } + } # - $test->nextCase(); + $test->nextCase(); # - + # $test->done(); # } -catch{ +catch{ $test -> dumpTermination($@); $test->doneFailed(); } - - - \ No newline at end of file diff --git a/tests/testShortLinks.pl b/tests/testShortLinks.pl index 5d99618..3ab73ad 100644 --- a/tests/testShortLinks.pl +++ b/tests/testShortLinks.pl @@ -1,5 +1,6 @@ use warnings; use strict; -use 5.36.0; + +use feature 'say'; use lib "system/modules"; use lib "tests"; @@ -7,14 +8,14 @@ require TestManager; require ShortLink; my $test = TestManager->new($0); -use Syntax::Keyword::Try; try{ +use Syntax::Keyword::Try; try { $test->case("List generation."); my $pickOne; my @docs = glob('~/Pictures/*.*'); foreach my $path(@docs){ -say +say ShortLink::obtain($path),":",$path; $pickOne = $path if rand(10) > 8 } @@ -55,7 +56,7 @@ $test->done(); # use IO::Compress::Xz qw(xz $XzError) ; - + # my $outxz; # xz \$text=> \$outxz or die "xz failed: $XzError\n"; # my $xenc = encode_base64($outxz); @@ -69,7 +70,7 @@ $test->done(); # say "dcp[".length($xdecomp)."]:".$xdecomp; } -catch{ +catch{ $test -> dumpTermination($@); $test->doneFailed(); } \ No newline at end of file -- 2.34.1