package DataProcessorPlugin;
use strict;
-use warnings;
+use warnings; no warnings qw(experimental::signatures);
use feature qw(signatures);
use Scalar::Util qw(looks_like_number);
}
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)
}
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;
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;
}#rof
shift @rows if($knock_out);
$$table->{data} = \@rows;
+ $$table->{data_processed} = 1;
}catch{
PluginException->throw(error=>"<p>Error->$@</p><br> processProperty('$property')</pre>", 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.
# 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;
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],
--- /dev/null
+###
+# 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=>"<p>Error->$@</p><br><pre>DSN: $dsn sql:$sql</pre>", 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<DATA> 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
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;
# require CNFDateTime;
CNFParser::import();
+our %MHDR = CNFMeta::TABLE_HEADER();
+our $TZ;
sub new ($class, $plugin){
my $settings;
$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;
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
$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;
}
}
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;
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";
package ShortLink;
-use 5.36.0;
-use warnings; use strict;
+
+use strict;
+use warnings;
+use feature 'signatures';
use Math::Base::Convert qw(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};
}
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.
$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;
}
($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){
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 '#'){
!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.
###
<<DB_SCHEMA <TREE>
[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[
<@@<ID auto>@@>
<@@<ID_ADDR not null>@@>
]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_CENTRAL<PLUGIN>
DB = test_db_central
DB_CREDENTIALS = admin/admin
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.
+#
<<DB_DATA_PRC<PLUGIN> ___HAS_PROCESSING_PRIORITY___
package : DataProcessorPlugin
subroutine : process
## 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.
<<USERS_DATA<DATA> __HAS_HEADER__
ID`email`name`ID_ADDR~
#`sjulia@smiths.fake.com`Julia Smith`01~
##
# 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 <PLUGIN> ___HAS_PROCESSING_PRIORITY___
package : DatabaseCentralPlugin
<<@<@directories>
~/.config
~/.local
-~/.vimrc
-~/.bashrc
+~/.local/share
>>
##
35`Income `Significant yearly income.~
>>
-<<RSS_FEEDS<DATA> __HAS_HEADER__ _CONST__
+<<RSS_FEEDS<DATA> __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
# 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";
# 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";
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";
$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;
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($@)
}
use warnings; use strict;
-use 5.36.0;
use lib "tests";
use lib "system/modules";
use warnings; use strict;
-use 5.36.0;
use lib "tests";
use lib "system/modules";
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(
<<SYS_DATE><DO>
use POSIX qw(strftime);
- print strftime "%F", localtime;
+ print strftime "%F", localtime;
>>
<<SYS_OS<DO>return "$^O">>
<<SYS_DATE<DO>____PRIORITY_1_`date`>>
<<A<TREE> _PRIORITY_2_
>>
<<B<TREE> _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..
>>
));
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
#!/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";
#!/usr/bin/env perl
use warnings; use strict;
-use v5.35;
+use feature 'say';
use lib "tests";
use lib "system/modules";
--- /dev/null
+#!/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 <DATA> ___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_CENTRAL<PLUGIN>
+ DB = test_db_central_schedule
+ DB_CREDENTIALS = admin/admin
+ DBI_SQL_SOURCE = DBI:SQLite:
+ package : DatabaseCentralPlugin
+ subroutine : main
+ property : DB_SCHEMA
+>><<DB_SCHEMA <TREE>
+
+ # 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();
+}
#!/usr/bin/env perl
use warnings; use strict;
use Syntax::Keyword::Try;
+use Math::Cartesian::Product;
use lib "tests";
use lib "system/modules";
require TestManager;
require CNFParser;
-use Math::Cartesian::Product;
+
my $test = TestManager -> new($0);
my $cnf;
#
$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 yet<moth?
- die $test->failed() 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() );
$test->case("Invalid date format, long, but could be parsable and passable.");
$cnf ->parse(undef,q(<<date_and_time<DATE>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());
}
$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);
use warnings; use strict;
-use 5.36.0;
+
use lib "tests";
use lib "system/modules";
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(
# 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.
#
<<<LIB libs/LoadTestPackage.pm>>>
#
#
- $test->nextCase();
+ $test->nextCase();
#
$test->case("Test Lib loading.");
$test->done();
#
}
-catch{
+catch{
$test -> dumpTermination($@);
$test->doneFailed();
}
-
-
-
\ No newline at end of file
use warnings; use strict;
use Syntax::Keyword::Try;
use Benchmark;
+
use lib "tests";
use lib "system/modules";
+
require TestManager;
require CNFParser;
require CNFSQL;
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(
-<<FlourWeight<2kg>>>
-<<@<%DualRatioFlourWater
- flour = 75%
- water = 25%
->>
-<<User<TABLE> __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(
+# <<FlourWeight<2kg>>>
+# <<@<%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{
+
+<<Users<DATA> __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~
>>
-<<Cities<TABEL> __SQL_TABLE__
+<<Cities<DATA> __SQL_TABLE__ _AUTONUMBER_
ID _INT_`Name _TEXT_~
>>
-<<Countries<TABLE> __SQL_TABLE__
-ID _INT_`Name`Surname`MiddleName`Address`Country`State~
+<<Countries<DATA>
+ID _INT_`Name _TEXT_~
#`Australia
>>
-<<States<TABEL> __SQL_TABLE__
+//No it is not an joke, some SQL data require this as an table. Otherwise you hardcode views and joins.
+<<States<DATA> __SQL_TABLE__ _AUTO_NUMBERED_
ID _INT_`Name _TEXT_~
#`NSW~
#`QLD~
#`NT~
>>
-<<Notes<TABLE> __SQL_TABLE__
+<<Notes<DATA> __SQL_TABLE__ _AUTONUMBER_
+ID _INT_`ID_User _INT_`Note _TEXT_~
+#`1`
+Hello World!`~
>>
- ));
+<<DB_CENTRAL<PLUGIN>
+ DB = test_db_central
+ DB_CREDENTIALS = admin/admin
+ DBI_SQL_SOURCE = DBI:SQLite:
+ package : DatabaseCentralPlugin
+ subroutine : main
+ property : DB_SCHEMA
+>>
+<<DB_SYNCH_DATE<DATE< _CONST_ now >>>
+<<DB_SCRIPT_ORIGIN<CONST<$0>>>
+
+
+##
+# 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.
+#
+
+<DB_SCHEMA_SHORTIFIED <TREE>
+ 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.
+<<DB_SCHEMA <TREE>
+ 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<
+ <@@<DATE TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP>@@>
+ <@@<LOG TEXT>@@>
+ >cols>
+ ]table]
+>>
+<< CNF_DB_SCHEMA_LOG <DATA> _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);
#
#
use warnings; use strict;
-use 5.36.0;
+
use lib "tests";
use lib "system/modules/";
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();
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');
}
}
#
- $test->nextCase();
+ $test->nextCase();
#
###
['<<anon>value>>', q(<span class='B'><<</span><span class='pa'>anon</span></span><span class='B'>></span><span class='pv'>value</span></span><span class='B'>>></span>)],
['<<anon<instruction>value>>', q(<span class='B'><<</span><span class='pa'>anon</span></span><span class='B'><</span><span class='pv'>instruction>value</span></span><span class='B'>>></span>)],
['<<CONST value>>', q(<span class='B'><<</span><span class='pi'>CONST</span></span><code class='pv'> value</code><span class='B'>>></span>)],
-
-
+
+
);
-#$a-><span class='B'><<<</span><span class='pa'>anon</span></span><code class='pv'> value</code><span class='B'>>>></span>,
-#$b-><span class='B'><<<</span><span class='pa'>anon</span></span> <code class='pv'> value</code><span class='B'>>>></span>
+#$a-><span class='B'><<<</span><span class='pa'>anon</span></span><code class='pv'> value</code><span class='B'>>>></span>,
+#$b-><span class='B'><<<</span><span class='pa'>anon</span></span> <code class='pv'> value</code><span class='B'>>>></span>
foreach (@cases){
$test->isDefined($case[0],$html);
say $test->failed("$case[0] CNF format has not properly converted!") if $html !~ /^<span class/;
$test->evaluate($case[0],$html,$case[1]);
- }
+ }
#
- $test->nextCase();
+ $test->nextCase();
#
-
+
#
$test->done();
#
}
-catch{
+catch{
$test -> dumpTermination($@);
$test->doneFailed();
}
-
-
-
\ No newline at end of file
use warnings; use strict;
-use 5.36.0;
+
+use feature 'say';
use lib "system/modules";
use lib "tests";
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
}
# use IO::Compress::Xz qw(xz $XzError) ;
-
+
# my $outxz;
# xz \$text=> \$outxz or die "xz failed: $XzError\n";
# my $xenc = encode_base64($outxz);
# say "dcp[".length($xdecomp)."]:".$xdecomp;
}
-catch{
+catch{
$test -> dumpTermination($@);
$test->doneFailed();
}
\ No newline at end of file
lifelog.hopto.org / PerlCNF.git / commitdiff