+++ /dev/null
-# Configuration Network File Format Specifications - DATA
-
-
-<span id="content" class="span-content">This section is part of the main ⇾ [CNF specifications](docs/PerlCNF/Specifications_For_CNF_ReadMe.md)</span>
-
-
-## CNF Data and SQL Document Section
-
-CNF scripted delimited data property, having uniform table data rows.
-The data is converted by default into arrays as rows. If it contains a header (recommended) these becomes the header of the data. A table header will be produced that contains the row's column's information, like name and type specs.
-The table header contains the actual data reference.
-
-This table is and specs are used to access, map and translate the data.
-There is a basic header being created by the parser and placed into its data hash.
-
-Example on how to access the data table of a property.
-
-```Perl
-my $table = CNFParser->new(...)->data(){'MyDataProperty'};
-my $header = $$table->{header};
-my $lbls = CNFMeta::_deRefArray(@$$header[0]);
-my $spec = CNFMeta::_deRefArray(@$$header[3]);
-my $data = CNFMeta::_deRefArray($$table->{data});
-```
-
-## SQL Based CNF Instruction
->
-> The following reserved words or instructions a data and SQL related.
-<style>
- .CNF_md_table{
- background-color: beige;
- td{
- border-right: solid black 1px;
- border-bottom: solid #ab0433 1px;
- }
- }
-</style>
-<table class="CNF_md_table">
- <thead>
- <tr>
- <th>Instruction</th>
- <th>Decription</th>
- </tr>
- </thead>
- <tbody>
- <tr>
- <td>DATA</td>
- <td>CNF scripted delimited data property, expected to have uniform table data rows, where very first is the table header if provided.</td>
- </tr>
- <tr>
- <td>FILE</td>
- <td>CNF scripted delimited data property is in a separate data file location, from the current script.</td>
- </tr>
- <tr>
- <td>TABLE</td>
- <td> SQL create Table body statement part. These can unfortunately differ from one database system to another.</td>
- </tr>
- <tr>
- <td>INDEX</td>
- <td>SQL create Index body. Indexes provide faster and more efficient data searches and updates.</td>
- </tr>
- <tr>
- <td>VIEW</td>
- <td>SQL create View body. Views provide a faster and narrower snapshot of what can be a lot of data.</td>
- </tr>
- <tr>
- <td>SQL</td>
- <td>Direct SQL statement without any variable unknowns.</td>
- </tr>
- <tr>
- <td>MIGRATE</td>
- <td>Same as SQL instruction, but migrations related towards tables and the application version.</td>
- </tr>
- </tbody>
-</table>
-
-## CNFMeta SQL Related
->
->Meta tags in use are DATA instruction related.
-
-1. Meta for what actions on data and table is required.
- 1. <code>_SQL_PostgreSQL_</code>
- - Data is to be linked or related to a Postgres SQL Database, default is SQLite.
- - In cases where the SQL underlining driver is something different from SQLite or Postgres this should be set to true and hope for the best.
- 2. <code>_SQL_TABLE_</code>
- - Create or link to an SQL Table equivalent.
- 3. <code>AUTO_NUMBERED</code>
- - ID column is auto numbered from 1-* if an '#' is found as the value.
- 4. <code>_HAS_HEADER_</code>
- - Specifically instruct first record is the header labels and specs for the columns.
- 5. Column CNF type is optionally placed next to header label, default column type is TEXT.
- - i.e. <code> `ID _INT_`Name _TEXT_`Entered _DATE_`Active _BOOL_~ </code>
-
-### Table Column CNF Data Types
-
-1. Column Data type are geared towards the CNF data type provision.
- 1. See %CNFMeta::CNF_DATA_TYPES global.
- - BOOL INT NUMBER DATE TEXT
- 2. The date type is specific in CNF set to an universal date and time stamp of <code>YYY-MM-DD hh:mm:ss</code>.
- 3. Global $CNFMeta::SQL_CNF_VAR_LENGTH = 2024; can be changed to provide for the __TEXT__ limit translation of specified columns for a database. You can expect database errors if inserting texts that is larger than this variable limit
-
-### CNSQL Package
-
-- Accessed as a global instance of CNFParser, it is the SQL based utility for external database interactions.
-- Its actual use is expected to be via a PLUGIN instructed CNF property, to provide driver to be used, credentials and other details.
-- Example method to use it: `my $sql = CNFParser->new()->SQL();`
-- Required method when using tables with a database based storage:`$sql->initDatabase($db, $do_not_auto_synch, $map)`
-- The __DataProcessingPlugin__ provides the concept of processing the scripted data to to CNF table column type conversion.
- - The parser provided header gets updated by this plugin.
- - The parsers natural processing mechanism will require all SQL properties in raw form before a plugin is called to process further.
-
->The following is extract from the original ⇾ <span id="content"> [specifications](docs/PerlCNF/Specifications_For_CNF_ReadMe.md)</span>.
-
-### CNF DATA Instruction
-
-CNF Instructions are parallel with the reserved words. Which means, you can't use these reserved words to replace with your own instruction. This section explains in more detail, what these are, and how are implemented.
-
-1. DATA
- 1. Data is specifically parsed, not requiring quoted strings and isn't delimited by new lines alone.
- 2. Data rows are ended with the __"~"__ delimiter. In the tag body.
- 3. Data columns are delimited with the invert quote __"`"__ (back tick) making the row.
- 4. First column can be taken as the unique and record identity column (UID).
- 1. If no UID is set, or specified with # or, 0, ID is considered to be auto-numbered based on data position plus 1, so not to have zero IDs.
- 2. When UID is specified, an existing previous assigned UID cannot be overridden, therefore can cause duplicates.
- 3. Data processing plugins can be installed to cater and change behavior on this whole concept.
- 5. Data is to be updated in storage if any column other than the UID, has its contents changed in the file.
- 1. This behavior can be controlled by disabling something like an auto file storage update. i.e. during application upgrades. To prevent user set settings to reset to factory defaults.
- 2. The result would then be that database already stored data remains, and only new ones are added. This exercise is out of scope of this specification.
- 6. First row labels the columns and is prefixed to PerlCNF datatype.
- 1. Generic data rows, do not require, but processors and plugins would definitely need it.
- 2. Current known types are, __@__{label} as CNFDateTime, __#__ for number or if in row autonumbering to be applied. Text is default without signifier.
-
- ```CNF
- <<MyAliasTable<DATA
- 01`admin`admin@inc.com`Super User~
- 02`chef`chef@inc.com`Bruno Allinoise~
- 03`juicy`sfox@inc.com`Samantha Fox~
- >>
- ```
-
-2. FILE
- 1. Expects a file name assigned value, file containing actual further CNF DATA rows instructions, separately.
- 2. The file is expected to be located next to the config file.
- 3. File is to be sequentially buffer read and processed instead as a whole in one go.
- 4. The same principles apply in the file as to the DATA instruction CNF tag format, that is expected to be contained in it.
-
- ```CNF
- <<MyItemsTbl<FILE data_my_app.cnf>
- ```
-
-## CNF Meta Instructions
-
-> Various Meta instructions are available to aid processing and decision making
-
-***
-
- Document is from project ⇾ <https://lifelog.hopto.org/gitweb/?p=PerlCNF.git>
-
- An open source application.
-
- Please refer to this specifications header and item or section points, on any desired clarifications or research/troubleshooting inquires.
-
-<center>Sun Stage - v.1.0 2024</center>
+++ /dev/null
-#!/usr/bin/perl -w
-#
-# Programed by: Will Budic
-# Open Source License -> https://choosealicense.com/licenses/isc/
-#
-use strict;
-use warnings;
-use DBI;
-use Exception::Class;
-
-
-use lib "system/modules";
-use lib $ENV{'PWD'}.'/htdocs/cgi-bin/system/modules';
-
-require Settings;
-
-
-my $dsn = "DBI:SQLite:dbname=/home/will/dev/LifeLog/dbLifeLog/data_admin_log.db";
-my $db = DBI->connect( $dsn, "admin", "admin", { PrintError => 0, RaiseError => 1 } )
- or Exception->throw("Connect failed [$_]");
-
-Settings::getConfiguration($db,{backup_enabled=>1});
-print "backup_enabled1:[".Settings::anon('backup_enabled')."]\n";
-my @r = Settings::anons();
-print "anon_size:[".@r."]@r\n";
-
-
-Settings::getConfiguration($db);#in file set to 0
-print "backup_enabled2:[".Settings::anon('backup_enabled')."]\n";
-Settings::getConfiguration($db,{backup_enabled=>1});#this is later, code set.
-print "backup_enabled3:[".Settings::anon('backup_enabled')."]\n";
-Settings::getConfiguration($db);#Murky waters, can't update an anon later through code. Config initially set.
-print "backup_enabled4:[".Settings::anon('backup_enabled')."]\n";
-
-# my $s1 ="`1`2`3`te\\`s\\`t`the best`";
-
-# $s1 =~ s/\\`/\\f/g;
-# #print $s1,"\n";
-# foreach ( split ( /`/, $s1) ){
-# $_ =~ s/\\f/`/g;
-# print $_,"\n";
-# }
-# print "Home:".$ENV{'PWD'}.$ENV{'NL'};
-
-
-
-1;
use constant{
FORMAT => '%Y-%m-%d %H:%M:%S',
+ FORMAT_Z => '%Y-%m-%d %H:%M:%S %Z',
FORMAT_NANO => '%Y-%m-%d %H:%M:%S.%3N %Z',
FORMAT_SCHLONG => '%A, %d %B %Y %H:%M:%S %Z',
FORMAT_MEDIUM => '%d %b %Y %H:%M:%S',
DEFAULT_TIME_ZONE => 'UTC'
};
-sub new {
- my $class = shift;
+# CNFDateTime instances begin with now, can be epoch zero that is $NULL, or _toCNFDateParsed(), they are never new.
+# epoch attibute if not been given will be setting it to now or current time and date.
+# TZ attribute if not given will use DEFAULT_TIME_ZONE. Avoid to pass only fat arrow type arguments.
+# my $now = CNFDateTime->now(TZ=>$my_zoneh); # <- wrong translates to array of arguments and $my_zone might be undef.
+# my $now = CNFDateTime->now({TZ=>$my_zone}); # <- proper way set with a hash even if $my_zone might be undef.
+# my $now = CNFDateTime->now($my_zone); # <- proper even if $my_zone might be undef.
+sub now {
+ my ($class,$presume,$r) = @_;
my %settings;
- if(ref($_[0]) ne ''){
- %settings = %{$_[0]}
- }
- $settings{epoch} = time if !$settings{epoch};
- $settings{TZ} = DEFAULT_TIME_ZONE if !$settings{TZ};
+ $r = ref($presume) if !$r;
+ if($r eq 'HASH') { %settings = %$presume }
+ elsif ($r eq '' ){ $settings{TZ} = $presume }
+ elsif( $presume =~ /TZ|tz/){ $settings{TZ} = $r}
+ $settings{epoch} = time if not exists $settings{epoch};
+ $settings{TZ} = DEFAULT_TIME_ZONE if not defined $settings{TZ};
return bless \%settings, $class
}
+use constant NULL => CNFDateTime->now({epoch=>0,TZ=>DEFAULT_TIME_ZONE});
+
+sub _toCNFDate ($formated, $timezone) {
+ my $dt = DateTime::Format::DateParse->parse_datetime($formated, $timezone);
+ die "Unable to parse date:" if not $dt;
+ return now('CNFDateTime',{epoch => $dt->epoch, datetime=>$dt, TZ=>$timezone})
+}
+
+
sub datetime($self) {
return $self->{datetime} if exists $self->{datetime};
- $self->{epoch} = time if not defined $self->{epoch};
- my $dt = DateTime->from_epoch(epoch=>$self->{epoch},time_zone=>$self->{TZ});
+ my $dt = DateTime->from_epoch({epoch=>$self->{epoch},time_zone=>$self->{TZ}});
$self->{datetime} = $dt;
return $dt
}
-sub toTimestamp($self) {
+sub toDateTimeFormat($self) {
return $self->{timestamp} if exists $self->{timestamp};
usleep(1_028_69);
- $self->{timestamp} = $self->datetime() -> strftime(FORMAT_NANO)
+ $self->{timestamp} = $self->datetime() -> strftime(FORMAT)
}
-sub toTimestampShort($self) {
+sub toDateTimeFormatWithZone($self) {
return $self->{timestamp} if exists $self->{timestamp};
usleep(1_028_69);
- $self->{timestamp} = $self->datetime() -> strftime(FORMAT)
+ $self->{timestamp} = $self->datetime() -> strftime(FORMAT_Z)
+}
+sub toTimestamp($self) {
+ return $self->{timestamp} if exists $self->{timestamp};
+ usleep(1_028_69);
+ $self->{timestamp} = $self->datetime() -> strftime(FORMAT_NANO)
}
sub toSchlong($self){
return $self->{long} if exists $self->{long};
$self->{long} = $self->datetime() -> strftime(FORMAT_SCHLONG)
}
-sub _toCNFDate ($formated, $timezone) {
- my $dt = DateTime::Format::DateParse->parse_datetime($formated, $timezone);
- die "Unable to parse date:" if not $dt;
- return new('CNFDateTime',{epoch => $dt->epoch, datetime=>$dt, TZ=>$timezone});
-}
+
sub _listAvailableCountryCodes(){
require DateTime::TimeZone;
return DateTime::TimeZone->countries();
package CNFMeta;
use strict;
-use warnings;
+use warnings; no warnings qw(experimental::signatures);
###
# Returns the regular expresion for any of the meta constances.
use constant PRIORITY => qr/(\s*\_+PRIORITY\_(\d+)\_+\s*)/o;
###
-# Global, there is possible only four CNF data types.
+# Globals, there is possible only four CNF data types.
our %CNF_DATA_TYPES;# ^ # % @ $ (default)
-BEGIN{my $cnt =0; foreach(qw{BOOL INT NUMBER DATE TEXT}){$CNF_DATA_TYPES{$_}=++$cnt}}
+our %TABLE_HEADER;#Array of six including sql insert I_BODY and I_val for updates.
+BEGIN {
+my $cnt =0; foreach(qw{BOOL INT NUMBER DATE TEXT}){$CNF_DATA_TYPES{$_}=++$cnt}
+ $cnt =0; foreach(qw{COL_NAMES COL_TYPES ID_PRIMARY ID_TYPE T_BODY I_BODY I_VAL S_BODY}){$TABLE_HEADER{$_}=$cnt++}
+}
###
# Global setting for SQL TEXT to CNF _TEXT_ specified data type range. Programatically changable.
our $SQL_CNF_VAR_LENGTH = 2024;
+sub TABLE_HEADER {
+ return %TABLE_HEADER;
+}
+
sub import {
my $caller = caller; no strict "refs";
{
-
# TREE instuction meta.
*{"${caller}::meta_has_priority"} = sub {return _meta("HAS_PROCESSING_PRIORITY")};
# Schedule to process before the rest in synchronous line of instructions.
###
# CNF DATA instruction headers can contain extra expected data type meta info.
-# This will strip them out and build the best expected SQL create table body, based on this meta.
-# I know, this is crazy stuff, skips having to have to use the TABLE instruction in most cases.
+# This will strip them out and build the best expected SQL create table body, based on this meta provided.
+# I know, this is making the whole concept a jigsaw puzzle, but it tries also to skip to have
+# a need for a TABLE instruction in most expected cases.
+# It is needed to automate creation and validation of most of the SQL based on CNF script provided data.
+# For support of database flavours other than SQLite and Postgres,s this would be the starting point to
+# to update, as it will be seen as if postgress building has been passed by parser. Good luck!
###
sub _metaTranslateDataHeader {
my $isPostgreSQL = shift;
- my @array = @_; my @spec;
- my ($idType,$body,$primary)=('NONE');
- my ($INT,$BOOL,$TEXT,$DATE,$ID, $CNFID, $INDEX) = (
+ my @header; my @array = @_; my @spec;
+ my ($idType,$body,$tins,$vins,$sels,$primary_set,$primary)=('NONE');
+ my ($INT,$BOOL,$TEXT,$DATE,$ID, $CNFID, $INDEX, $AUTO) = (
_meta('INT'),_meta('BOOL'),_meta('TEXT'),_meta('DATE'),
- _meta('ID'),_meta('CNF_ID'),_meta('CNF_INDEX')
+ _meta('ID'),_meta('CNF_ID'),_meta('CNF_INDEX'),_meta('AUTO')
);
for my $i (0..$#array){
my $hdr = $array[$i];
- if($hdr eq 'ID'){
+ if(not $primary_set and $hdr eq "ID" or $hdr =~ s/$AUTO/""/ei){
if($isPostgreSQL){
$body .= "\"$hdr\" INT UNIQUE PRIMARY KEY GENERATED ALWAYS AS IDENTITY,\n";
- #$primary = "PRIMARY KEY(ID)"
}else{
$body .= "\"$hdr\" INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,\n";
}
# DB provited sequence, you better don't set this when inserting a record.
$spec[$i] = $CNF_DATA_TYPES{INT};
+ $primary = $hdr;
+ $primary_set = 1;
$idType = 'AUTOINCREMENT'
- }elsif($hdr =~ s/$CNFID/""/ei){
+ }elsif($hdr =~ s/$CNFID/""/ei || $i==0 && $hdr eq "ID"){
#This is where CNF provides the ID uinque int value (which doesn't have to be autonumbered i.e. '#', but must be unique).
$body .= "\"$hdr\" INTEGER NOT NULL PRIMARY KEY CHECK (\"$hdr\">0),\n";
$spec[$i] = $CNF_DATA_TYPES{INT};
- $idType = 'CNF_INDEX'
+ $primary = $hdr;
+ $primary_set = 1;
+ $idType = 'CNF_ID'
}elsif($hdr =~ s/$ID/""/ei){
#This is ID prefix to some other data id stored in this table, usually one to one/many relationship.
$body .= "\"$hdr\" INTEGER CHECK (\"$hdr\">0),\n";
+ $tins .= $hdr . ',';$vins .= "?,";
$spec[$i] = $CNF_DATA_TYPES{INT};
+ $idType = 'ID'
}elsif($hdr =~ s/$INDEX/""/ei){
# This is where CNF instructs to make a indexed lookup type field,
# for inside database fast selecting, hashing, caching and other queries.
$body .= "\"$hdr\" varchar(64) NOT NULL PRIMARY KEY,\n";
+ $tins .= $hdr . ',';
$spec[$i] = $CNF_DATA_TYPES{TEXT};
+ $idType = 'CNF_INDEX'
}elsif($hdr =~ s/$INT/""/ei){
$body .= "\"$hdr\" INTEGER NOT NULL,\n";
+ $tins .= $hdr . ','; $vins .= "?,";
$spec[$i] = $CNF_DATA_TYPES{INT};
}elsif($hdr =~ s/$BOOL/''/ei){
if($isPostgreSQL){
- $body .= "\"$hdr\" BOOLEAN NOT NULL,\n";
+ $body .= "\"$hdr\" BOOLEAN NOT NULL,\n";
}else{
- $body .= "\"$hdr\" BOOLEAN NOT NULL CHECK (\"$hdr\" IN (0, 1)),\n";
+ $body .= "\"$hdr\" BOOLEAN NOT NULL CHECK (\"$hdr\" IN (0, 1)),\n";
}
+ $tins .= $hdr . ','; $vins .= "?,";
$spec[$i] = $CNF_DATA_TYPES{BOOL};
}elsif($hdr =~ s/$TEXT/""/ei){
$body .= "\"$hdr\" TEXT NOT NULL CHECK (length(\"$hdr\")<=$SQL_CNF_VAR_LENGTH),\n";
+ $tins .= $hdr . ','; $vins .= "?,";
$spec[$i] = $CNF_DATA_TYPES{TEXT};
}elsif($hdr =~ s/$DATE/""/ei){
$body .= "\"$hdr\" TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP,\n";
+ $tins .= $hdr . ','; $vins .= "?,";
$spec[$i] = $CNF_DATA_TYPES{DATE};
}else{
$body .= "\"$hdr\" TEXT NOT NULL,\n";
+ $tins .= $hdr . ','; $vins .= "?,";
$spec[$i] = $CNF_DATA_TYPES{TEXT};;
}
- $array[$i] = $hdr;
+ $array[$i] = $hdr; $sels .= "$hdr,";
}
- if($primary){
- $body .= $primary;
- }else{
- $body =~ s/,$//
- }
-return \[\@array,\$body,$idType,\@spec];
+ $sels =~ s/,$//;
+ $body =~ s/,$//; $tins =~ s/,$//; $vins =~ s/,$//;
+ $header[$TABLE_HEADER{ID_TYPE}] = \$idType;
+ $header[$TABLE_HEADER{ID_PRIMARY}] = \$primary;
+ $header[$TABLE_HEADER{T_BODY}] = \$body;
+ $header[$TABLE_HEADER{I_BODY}] = \$tins;
+ $header[$TABLE_HEADER{I_VAL}] = \$vins;
+ $header[$TABLE_HEADER{S_BODY}] = \$sels;
+return _MakeTableHeader(\@header,\@array,\@spec);
}
-
+###
+# Table Header builder routine required to be called when header is made or recreated.
+# Such builder pattern avoids us to make a looked up type, it is faster and better also in for gc.
+# It is drirect strict ordinal order referenced header array access. So before use this ubroutine must be called.
+# And when header is modified this subrotine also must be modified, otherwise fatal errors, which is good.
+#
+sub _MakeTableHeader{ my ($header,$lbls,$spec) = @_;
+my @hdr = @$header;
+return \[
+ $lbls,
+ $spec,
+ $hdr[$TABLE_HEADER{ID_PRIMARY}],
+ $hdr[$TABLE_HEADER{ID_TYPE}],
+ $hdr[$TABLE_HEADER{T_BODY}],
+ $hdr[$TABLE_HEADER{I_BODY}],
+ $hdr[$TABLE_HEADER{I_VAL}],
+ $hdr[$TABLE_HEADER{S_BODY}]
+];
+}
+###
+# Resolves if an scalar reference is an array reference or a reference to an array refference..
+# i.e. my @header = CNFMeta::_deRefArray($$table->{header}); is safer and required
+# when the foolowwing fails ->
+# my @header = @($$table->{header}};
+#
sub _deRefArray {
- my $ret = shift;
-
- if ( ref($ret) eq 'ARRAY' ){
+ my $ret = shift; return [] if not $ret;
+ my $ref = ref($ret);
+ if($ref eq 'ARRAY'){
my @arr = @{$ret};
if(@arr==1 && ref($arr[0]) eq 'ARRAY'){
@arr = @{$arr[0]};
}
return @arr
+ }elsif($ref eq 'REF'){
+ return @$$ret;
+ }elsif($ref eq 'SCALAR'){
+ return $$ret;
}
return $ret
}
+sub _obtainColumnMap {
+ my $table = shift;
+ my @header = CNFMeta::_deRefArray($$table->{header});
+ my @names = CNFMeta::_deRefArray($header[$TABLE_HEADER{COL_NAMES}]);
+ my %ret;
+ foreach my $i(0..$#names){ $ret{$names[$i]}=$i }
+ return \%ret
+}
+use feature qw(signatures);
+use Scalar::Util qw(looks_like_number);
+sub _matchType($type, $val, @rows) {
+ if ($type == $CNF_DATA_TYPES{BOOL}){return 1}
+ elsif($type == $CNF_DATA_TYPES{INT} || $type == $CNF_DATA_TYPES{NUMBER} && looks_like_number($val)){return 1}
+ elsif($type == $CNF_DATA_TYPES{DATE}){
+ if($val=~/\d*\/\d*\/\d*/){return 1}
+ else{
+ return 1;
+ }
+ }
+ elsif($type==$CNF_DATA_TYPES{TEXT}){return 1}
+ return 0;
+}
+sub _zero_prefix ($times, $val) {
+ if($times>0){
+ return '0'x$times.$val;
+ }else{
+ return $val;
+ }
+}
1;
\ No newline at end of file
$val = $script;
}
}else{
+
my @lines = split(/\n/, $script);
foreach my $ln(@lines){
$ln =~ s/^\s+|\s+$//g;
if(length ($ln)){
- my $isShortife = ($ln =~ s/($meta_shortife)/""/sexi);
+ my $isShortife = $ln =~ s/($meta_shortife)/""/sexi;
if($ln =~ /^([<>\[\]])(.*)([<>\[\]])$/ && $1 eq $3){
$sta = $1;
$tag = $2;
my $property = CNFNode->new({'_'=>$sub, '@' => \$self});
my $a = $isArray;
if($isShortifeScript){
- my ($sub,$prev,$cnt_nl,$bck_p);
- while ($body =~ / (.*)__+ ([\\\|]|\/*) | (.*)[:=](.*) | (.*)\n/gmx){
- my @sel = @{^CAPTURE};
- if(defined $sel[0]){
- if ($sel[1]){
- my $t = substr $sel[1],0,1;
- $bck_p=length($sel[1]);
- my $parent = $sub;
- if($t eq '\\'){
- $parent = $sub ? $sub : $property;
- }elsif($t eq '|'){
- $parent = $sub ? $sub->parent() : $prev;
- }elsif($t eq '/') {
- while(--$bck_p>0){
- $parent = $parent -> parent() if $parent -> parent();
- my $ref = ref($parent); $parent = $$parent if $ref eq 'REF';
- }
- if ($sel[0] eq ''){
- $sub = $parent; next
- }
- }
- $t = $sel[0]; $t=~s/[\s_]*$//g;
- $sub = CNFNode->new({'_' => $t, '@' => $parent});
- #my $ref = ref($parent); $parent = $$parent if $ref eq 'REF';
- my @elements = $parent -> {'@$'} ? $parent -> {'@$'} : ();
- $elements[@elements] = $sub; $prev = $parent; $cnt_nl = 0;
- $parent -> {'@$'} = \@elements;
- }
- }
- elsif (defined $sel[2] && defined $sel[3]){
- my $attribute = $sel[2]; $attribute =~ s/^\s*|\s*$//g;
- my $value = $sel[3]; $value =~ s/^\s*|\s*$//g;
- if($sub){
- $sub -> {$attribute} = $value
- }else{
- $property -> {$attribute} = $value
- }
- $cnt_nl = 0;
- }
- elsif (defined $sel[4]){
- if ($sel[4] eq ''){
- if(++$cnt_nl>1){ #cancel collapse chain and at root of property that is shorted.
- ##$sub = $property ;
- $cnt_nl =0
- }
- next
- }elsif($sel[4] !~ /^\s*\#/ ){
- my $parent = defined $sub ? $sub : $property;
- #my $ref = ref($parent); $parent = $$parent if $ref eq 'REF';
-
- if (exists $parent->{'#'}){
- $parent->{'#'} .= "\n" . $sel[4]
- }else{
- $parent->{'#'} = $sel[4]
- }
- }
- }
- }#while
- $isShortifeScript = 0;
+ _parseShortife($property,$body);
+ $isShortifeScript = 0
}else{
$property -> process($parser, $body);
}
$self->{'#'} = qq($ln\n);
}
}
+ elsif($isShortife){
+ $isShortifeScript = 1; $opening++;
+ next;
+ }
elsif($opening < 1){
if($ln =~m/^([<\[]@@[<\[])(.*?)([>\]@@[>\]])$/){
$array[@array] = $2;
}
}
}
+
+ if($isShortifeScript && $body){
+ _parseShortife($self,$body)
+ }
+
$self->{'@@'} = \@array if @array;
$self->{'#'} = \$val if $val;
## no critic BuiltinFunctions::ProhibitStringyEval
return \$self;
}
+sub _parseShortife {
+ my($property,$body) = @_;
+ my ($sub,$prev,$cnt_nl,$bck_p);
+ while ($body =~ / (.*)__+ ([\\\|]|\/*) | (.*)[:=](.*) | (.*)\n/gmx){
+ my @sel = @{^CAPTURE};
+ if(defined $sel[0]){
+ if ($sel[1]){
+ my $t = substr $sel[1],0,1;
+ $bck_p=length($sel[1]);
+ my $parent = $sub;
+ if($t eq '\\'){
+ $parent = $sub ? $sub : $property;
+ }elsif($t eq '|'){
+ $parent = $sub ? $sub->parent() : $prev;
+ }elsif($t eq '/') {
+ while(--$bck_p>0){
+ $parent = $parent -> parent() if $parent -> parent();
+ my $ref = ref($parent); $parent = $$parent if $ref eq 'REF';
+ }
+ if ($sel[0] eq ''){
+ $sub = $parent; next
+ }
+ }
+ $t = $sel[0]; $t=~s/[\s_]*$//g;
+ $sub = CNFNode->new({'_' => $t, '@' => $parent});
+ #my $ref = ref($parent); $parent = $$parent if $ref eq 'REF';
+ my @elements = $parent -> {'@$'} ? $parent -> {'@$'} : ();
+ $elements[@elements] = $sub; $prev = $parent; $cnt_nl = 0;
+ $parent -> {'@$'} = \@elements;
+ }
+ }
+ elsif (defined $sel[2] && defined $sel[3]){
+ my $attribute = $sel[2]; $attribute =~ s/^\s*|\s*$//g;
+ my $value = $sel[3]; $value =~ s/^\s*|\s*$//g;
+ if($sub){
+ $sub -> {$attribute} = $value
+ }else{
+ $property -> {$attribute} = $value
+ }
+ $cnt_nl = 0;
+ }
+ elsif (defined $sel[4]){
+ if ($sel[4] eq ''){
+ if(++$cnt_nl>1){ #cancel collapse chain and at root of property that is shorted.
+ ##$sub = $property ;
+ $cnt_nl =0
+ }
+ next
+ }elsif($sel[4] !~ /^\s*\#/ ){
+ my $parent = defined $sub ? $sub : $property;
+ #my $ref = ref($parent); $parent = $$parent if $ref eq 'REF';
+
+ if (exists $parent->{'#'}){
+ $parent->{'#'} .= "\n" . $sel[4]
+ }else{
+ $parent->{'#'} = $sel[4]
+ }
+ }
+ }
+ }
+}
+
+
sub obtainLink {
my ($self,$parser,$link, $ret) = @_;
## no critic BuiltinFunctions::ProhibitStringyEval
##no critic qw(Subroutines::RequireFinalReturn)
##no critic Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions
-use constant VERSION => '3.2';
+use constant VERSION => '3.3';
our @files;
our %lists;
our %properties;
###
our %ANONS;
#private -> Instance fields:
- my $anons;
+ my $ANONS;
my @includes; my $CUR_SCRIPT;
my %instructs;
my $IS_IN_INCLUDE_MODE;
#private to parser sub.
sub doInstruction { my ($self,$e,$t,$v) = @_;
- my $DO_ENABLED = $self->{'DO_ENABLED'}; my $priority = 0;
+ my $DO_ENABLED = $self->{'DO_ENABLED'}; my $priority = 0; my $isMetaConst;
$t = "" if not defined $t;
if($t eq 'CONST' or $t eq 'CONSTANT'){#Single constant with mulit-line value;
# It is NOT allowed to overwrite constant.
}
elsif($t eq 'VAR' or $t eq 'VARIABLE'){
$v =~ s/^\s//;
- $anons->{$e} = $v;
+ $ANONS->{$e} = $v;
}
elsif($t eq 'DATA'){
- $self->doDataInstruction_($e,$v)
+ $self->doDATAInstructions_($e,$v)
}elsif($t eq 'DATE'){
+ my $isMetaConst = $v =~ s/$meta_const//s;
if($v && $v !~ /now|today/i){
$v =~ s/^\s//;
if($self->{STRICT}&&$v!~/^\d\d\d\d-\d\d-\d\d/){
$self-> warn("Invalid date format: $v expecting -> YYYY-MM-DD at start as possibility of DD-MM-YYYY or MM-DD-YYYY is ambiguous.")
}
$v = CNFDateTime::_toCNFDate($v,$self->{'TZ'});
-
}else{
- $v = CNFDateTime->new({TZ=>$self->{'TZ'}});
+ $v = CNFDateTime->now({TZ=>$self->{'TZ'}});
+ }
+ if($isMetaConst){
+ $self ->{$e} = $v
+ }else{
+ $ANONS->{$e} = $v
}
- $anons->{$e} = $v;
}elsif($t eq 'FILE'){#@TODO Test case this
$self->doLoadDataFile($e,$v);
}elsif($t eq 'INCLUDE'){
+ my $isMetaConst = $v =~ s/$meta_const//s;
if (!$v){
$v=$e
}else{
- $anons = $v;
+ if ($isMetaConst){
+ $self -> {$e} = $v;
+ }else{
+ $ANONS = $v
+ }
}
my $prc_last = ($v =~ s/($meta_process_last)/""/ei)?1:0;
if (includeContains($v)){
$priority = $2;
}
if( $v=~ s/($meta_on_demand)/""/ei ){
- $anons->{$e} = CNFNode -> new({'_'=>$e,'&'=>$v,'^'=>$priority});
+ $ANONS->{$e} = CNFNode -> new({'_'=>$e,'&'=>$v,'^'=>$priority});
return;
}
## no critic BuiltinFunctions::ProhibitStringyEval
## use critic
if ($ret){
chomp $ret;
- $anons->{$e} = $ret;
+ $ANONS->{$e} = $ret;
}else{
$self->warn("Perl DO_ENABLED script evaluation failed to evalute: $e Error: $@");
- $anons->{$e} = '<<ERROR>>';
+ $ANONS->{$e} = '<<ERROR>>';
}
}else{
$self->warn("DO_ENABLED is set to false to process property: $e\n")
use Module::Load;
autoload $v;
$v =~ s/^(.*\/)*|(\..*)$//g;
- $anons->{$e} = $v;
+ $ANONS->{$e} = $v;
}catch{
$self->warn("Module DO_ENABLED library failed to load: $v\n");
- $anons->{$e} = '<<ERROR>>';
+ $ANONS->{$e} = '<<ERROR>>';
}
}else{
$self->warn("DO_ENABLED is set to false to process a LIB property: $e\n");
- $anons->{$e} = '<<ERROR>>';
+ $ANONS->{$e} = '<<ERROR>>';
}
}
elsif($t eq 'PLUGIN'){
#Register application statement as either an anonymous one. Or since v.1.2 a listing type tag.
if($e !~ /\$\$$/){ #<- It is not matching {name}$$ here.
if($self->{'HAS_EXTENSIONS'}){
- $anons->{$e} = InstructedDataItem->new($e,$t,$v)
+ $ANONS->{$e} = InstructedDataItem->new($e,$t,$v)
}else{
$v = $t if not $v;
if($e=~/^\$/){
$self->{$e} = $v if !$self->{$e}; # Not allowed to overwrite constant.
}else{
- $anons->{$e} = $v
+ $ANONS->{$e} = $v
}
}
}
$tag = substr $tag, 0, $i;
}
if($tag eq 'DATA'){
- $self->doDataInstruction_($e,$v)
+ $self->doDATAInstructions_($e,$v)
}
}
}
# DATA instructions are not preserved as CNF script values as would be redundand and a waist.
# They by default are only META translated into tables for efficiancy by data property name.
#private
-sub doDataInstruction_{ my ($self,$e,$v,$t,$d)=@_;
+sub doDATAInstructions_{ my ($self,$e,$v,$t,$d)=@_;
my $add_as_SQLTable = $v =~ s/${meta('SQL_TABLE')}/""/sexi;
my $isPostgreSQL = $v =~ s/${meta('SQL_PostgreSQL')}/""/sexi;
my $isAutonumber = $v =~ s/${meta('AUTO_NUMBERED')}|${meta('AUTONUMBER')}/""/sexi;
my $isConstant = $v =~ s/$meta_const//s;
my $isHeader = $v =~ s/${meta('HAS_HEADER')}/""/sexi;
$isHeader = 1 if !$isHeader && ($isAutonumber||$add_as_SQLTable||$isPostgreSQL);
-
my @hdr; my @rows; my $autonumber = 0;
my $ref = $self->{__DATA__}{$e};
if($ref){
push @a, $d;
}
}
-
- if(!@hdr && $isHeader){
+ # By CNF convention ID is assumed to be a header if [0][0] contains it use _HAS_HEADER_ meta to demand that it is from the sccript.
+ if(!@hdr && $isHeader || $a[0] eq 'ID'){#<--/
my $ptr = CNFMeta::_metaTranslateDataHeader($isPostgreSQL,@a);
- @hdr = @{$$ptr}; $isHeader = 0;
- $self->SQL()->createTable($e,${$hdr[1]},$hdr[2]) if $add_as_SQLTable
+ @hdr = @{$$ptr};
+ $isHeader = 0;
+ if ($add_as_SQLTable) {
+ my %mh = &CNFMeta::TABLE_HEADER;
+ my $idtyp = $hdr[ $mh{ID_TYPE} ];
+ my $tbody = $hdr[ $mh{T_BODY} ];
+ $self->SQL()->createTable( $e, $tbody, $idtyp )
+ }
}elsif(scalar @a > 0){
- if($isHeader){
- $isHeader = 0;
- }else{
- push @rows, [@a]
- }
+ $isHeader = 0; #autocorrect if _HAS_HEEADER_ header was accidently set.
+ push @rows, [@a]
}
}
my $ret = {name=>$e,header=>\@hdr,data=>\@rows,auto=>$autonumber};
$self->{__DATA__}{$e} = \$ret
}
+sub _fetchScriptStat{
+ my $cnf_file = shift;
+ my @stat = stat($cnf_file);
+ open(my $fh, "<:perlio", $cnf_file ) or die "Can't open $cnf_file -> $!";
+ close $fh;
+ return \@stat;
+}
+
###
# Parses a CNF file or a text content if specified, for this configuration object.
##
my @tags;
if($self->{'ANONS_ARE_PUBLIC'}){
- $anons = \%ANONS;
+ $ANONS = \%ANONS;
}else{
- $anons = $self->{'__ANONS__'};
+ $ANONS = $self->{'__ANONS__'};
}
# We control from here the constances, as we need to unlock them if a previous parse was run.
$line = $3; $line =~ s/^\s*(['"])(.*)\g{1}$/$2/ if $line;#strip quotes
if(defined $name){
if($isVar && not $isMETAConst){
- $anons ->{$name} = $line if $line
+ $ANONS ->{$name} = $line if $line
}else{
$name =~ s/^\$// if $isMETAConst;
# It is NOT allowed to overwrite a constant, so check an issue warning.
}
}else{
$v =~ s/\s*>$//;
- $anons->{$t} = $v;
+ $ANONS->{$t} = $v;
}
}else{
$e = $1;
$t = $2;
$v = substr($tag,length($e)+length($t));
- $anons->{$e} = $v;
+ $ANONS->{$e} = $v;
next;
}
# Before mauling into possible value types, let us go for the full expected tag specs first:
my @arr = ($value =~ m/(\$\$\$.+?\$\$\$)/gm);
foreach my $find(@arr) {
my $s = $find; $s =~ s/^\$\$\$|\$\$\$$//g;
- my $r = $anons->{$s};
+ my $r = $ANONS->{$s};
$r = $self->{$s} if !$r;
$r = $instructs{$s} if !$r;
CNFParserException->throw(error=>"Unable to find property for $t.$name -> $find\n",show_trace=>1) if !$r;
my @arr = ($v =~ m/(\$\$\$.+?\$\$\$)/gm);
foreach my $find(@arr) {# <- MACRO TAG translate. ->
my $s= $find; $s =~ s/^\$\$\$|\$\$\$$//g;#
- my $r = %$anons{$s};
+ my $r = %$ANONS{$s};
$r = $self->{$s} if !$r;
if(!$r){
$self->warn("Unable to find property to translate macro expansion: $e -> $find\n");
$v =~ s/\Q$find\E/$r/g;
}
}
- $anons->{$e}=$v;
+ $ANONS->{$e}=$v;
}else{
$items[@items] = $struct;
}
my $type = ref($struct);
if($type eq 'CNFNode' && $struct-> priority() > 0){
$struct->validate() if $self->{ENABLE_WARNINGS};
- $anons ->{$struct->name()} = $struct->process($self, $struct->script());
+ $ANONS ->{$struct->name()} = $struct->process($self, $struct->script());
splice @items, $idx, 1
}
}
my $type = ref($struct);
if($type eq 'CNFNode'){
$struct->validate() if $self->{ENABLE_WARNINGS};
- $anons->{$struct->name()} = $struct->process($self, $struct->script());
+ $ANONS->{$struct->name()} = $struct->process($self, $struct->script());
}elsif($type eq 'InstructedDataItem'){
my $t = $struct->{ins};
if($t eq 'PLUGIN'){
my @pair = $ln =~ /\s*(\w+)[:=](.*)\s*/;
$ins = $1; $ins = $ln if !$ins;
$mth = $2;
- if($ins =~ /[a-z]/i){
- $args{$ins} = $mth;
- }
+ $args{$ins} = $mth if $ins =~ /[a-z]/i
}
if(exists $instructors{$ins}){
$self -> error("$package<$ins> <- Instruction has been previously registered by: ".ref(${$instructors{$ins}}));
}
}
+my @arr = [1,2,3];
+
+
###
# Generic CNF Link utility on this repository.
##
my $isWarning = $type eq 'WARNG';
my $attach = join @_; $message .= $attach if $attach;
my %log = $self -> property('%LOG');
- my $time = exists $self->{'TZ'} ? CNFDateTime -> new(TZ=>$self->{'TZ'}) -> toTimestamp() :
- CNFDateTime -> new()-> toTimestamp();
+ my $time = CNFDateTime -> now(exists($self->{TZ})?{TZ=>$self->{TZ}}:undef) -> toTimestamp();
$message = "$type $message" if $isWarning;
-
if($message =~ /^ERROR/ || ($isWarning && $self->{ENABLE_WARNINGS})){
warn $time . " " .$message;
}
}
}
-sub now {return CNFDateTime->new(shift)}
sub dumpENV{
foreach (keys(%ENV)){print $_,"=", "\'".$ENV{$_}."\'", "\n"}
use DBI;
use Tie::IxHash;
-use constant VERSION => '2.0';
+use constant VERSION => '2.1';
-our (%tables, %tables_id_type, %tables_data_map);
+our (%tables_creat_stmts, %tables_id_type, %tables_data_map);
our %views = ();
our %mig = ();
our @sql = ();
our @statements;
-our %curr_tables = ();
+our %schema_tables;
my $isPostgreSQL = 0;
my $hasRecords = 0;
my ($class, $attrs, $self) = @_;
$self = \%$attrs;
# By convention any tables and views as appearing in the CNF script should in that order also be created.
- tie %tables, "Tie::IxHash";
+ tie %tables_creat_stmts, "Tie::IxHash";
tie %views, "Tie::IxHash";
bless $self, $class;
}
##
# Required to be called when using CNF with an database based storage.
-# This subrotine is also a good example why using generic driver is not recomended.
+# This subrotine is also a good example why using generic driver for SQL is not recomended.
# Various SQL db server flavours meta info is def. handled differently and not updated in them.
#
# $map - The synch binding of an CNF TABLE to its CNF DATA property,
-# a header of the DATA instructed property with a meta _SQL_TABLE_ tag is self column resolving
-# based on ID not requiring this mapping now. To better explain, CNF data can have several data properties,
-# with the map we programatically instruct which on is the right one, per various possible tables?
+# a header of the DATA instructed property with a meta _SQL_TABLE_ tag is self column resolving
+# based on ID not requiring this mapping now. To better explain, CNF data can have several data properties,
+# with the map we programatically instruct which on is the right one, per various possible tables?
# @TODO 20231018 - Specifications page to be provided with examples for this.
+# @upd - Constants changed in script updates list.
#
-sub initDatabase { my($self, $db, $do_not_auto_synch, $map, $st) = @_;
+sub initDatabase { my($self, $db, $do_not_auto_synch, $map, @upd, $st) = @_;
#Check and set CNF_CONFIG
try{
+ %schema_tables = ();
+ $do_not_auto_synch = 0 if @upd;
$hasRecords = 0;
$isPostgreSQL = $db-> get_info( 17) eq 'PostgreSQL';
if($isPostgreSQL){
my @tbls = $db->tables(undef, 'public'); #<- This is the proper way, via driver, doesn't work on sqlite.
foreach (@tbls){
- my $t = uc substr($_,7); $t =~ s/^["']|['"]$//g;
- $curr_tables{$t} = 1;
+ my $table = uc substr($_,7); $table =~ s/^["']|['"]$//g;
+ $schema_tables{$table} = 1;
}
}
else{
my $pst = selectRecords($self, $db, "SELECT name FROM sqlite_master WHERE type='table' or type='view';");
- while(my @r = $pst->fetchrow_array()){
- $curr_tables{$r[0]} = 1;
- }
+ if($pst){while(my @r = $pst->fetchrow_array()){
+ $schema_tables{$r[0]} = 1;
+ }}
}
- if(!$curr_tables{CNF_CONFIG}){
+ if(!$schema_tables{CNF_CONFIG}){
my $stmt;
if($isPostgreSQL){
$stmt = qq|
$self->{parser}->log("CNFParser-> Created CNF_CONFIG table.");
$st = $db->prepare('INSERT INTO CNF_CONFIG VALUES(?,?,?);');
foreach my $key(sort keys %{$self->{parser}}){
- my ($dsc,$val);
+ my ($dsc,$val,$ref);
$val = $self->{parser}->const($key);
- if(ref($val) eq ''){
+ $ref = ref($val);
+ if($ref eq 'CNFDateTime'){
+ $ref =''; $val = $val -> toDateTimeFormatWithZone()
+ }
+ if($ref eq ''){
my @sp = split '`', $val;
if(scalar @sp>1){$val=$sp[0];$dsc=$sp[1];}else{$dsc=""}
$st->execute($key,$val,$dsc);
}
$db->commit();
}else{ unless ($do_not_auto_synch){
+
+
+
my $sel = $db->prepare("SELECT VALUE FROM CNF_CONFIG WHERE NAME LIKE ?;");
+ my $upd = $db->prepare("UPDATE CNF_CONFIG SET VALUE = ?, DESCRIPTION = ? WHERE NAME LIKE ?;");
my $ins = $db->prepare('INSERT INTO CNF_CONFIG VALUES(?,?,?);');
+ $db->begin_work();
foreach my $key(sort keys %{$self->{parser}}){
- my ($dsc,$val);
+ my ($dsc,$val,$ref);
$val = $self->{parser}->const($key);
- if(ref($val) eq ''){
+ $ref = ref($val);
+ if($ref eq 'CNFDateTime'){
+ $ref =''; $val = $val -> toDateTimeFormat()
+ }
+ if($ref eq ''){
$sel->execute($key);
my @a = $sel->fetchrow_array();
if(@a==0){
my @sp = split '`', $val;
if(scalar @sp>1){$val=$sp[0];$dsc=$sp[1];}else{$dsc=""}
$ins->execute($key,$val,$dsc);
+ }elsif(@upd){
+ foreach my $find(@upd){
+ if($find eq $key){
+ my @sp = split '`', $val;
+ if(scalar @sp>1){$val=$sp[0];$dsc=$sp[1];}else{$dsc=""}
+ $upd->execute($val,$dsc, $key);
+ last;
+ }
+ }
}
}
}
+ $db->commit();
}}
###
# By default we automatically data insert synchronize script with database state on every init.
- # If set $do_not_auto_synch = 1 we skip that if table is present, empty or not,
- # and if has been updated dynamically that is good, what we want. It is of external config. implementation choice.
- foreach my $tbl(keys %tables){
- if(!$curr_tables{$tbl}){
- $st = $tables{$tbl};
+ # If set $do_not_auto_synch = 1 we skip that if a table is present, empty or not,
+ # and if has been updated dynamically that is good, as this is what we want.
+ # It is of external config. implementation choice.
+ if($map && ($_= %$map{central_schema})){
+ # Out of scope us at the moment multiple shema managment requested init.
+ # So return what is in the database detected only.
+ $self->{parser}->log("CNFParser-> SQL: Initiated database for central_schema: $_\n");
+ return \%schema_tables;
+ }
+ foreach my $tbl_stm(keys %tables_creat_stmts){
+ if(!$schema_tables{$tbl_stm} && !$schema_tables{uc $tbl_stm}){
+ $st = $tables_creat_stmts{$tbl_stm};
$self->{parser}->log("CNFParser-> SQL: $st\n");
- try{
+ try {
$db->do($st);
- $self->{parser}->log("CNFParser-> Created table: $tbl\n");
+ $self->{parser}->log("CNFParser-> Created table: $tbl_stm\n");
$do_not_auto_synch = 0;
}catch{
die "Failed to create:\n$st\nError:$@"
next if $do_not_auto_synch;
}
}
- foreach my $tbl(keys %tables){
+ foreach my $tbl_stm(keys %tables_creat_stmts){
next if $do_not_auto_synch;
my @table_info;
- my $tbl_id_type = $tables_id_type{$tbl};
+ my $tbl_id_type = $tables_id_type{$tbl_stm};
if(isPostgreSQL()){
- $st = lc $tbl; #we lc, silly psql is lower casing meta and case sensitive for internal purposes.
+ $st = lc $tbl_stm; #we lc, silly psql is lower casing meta and case sensitive for internal purposes.
$st="select ordinal_position, column_name, data_type from information_schema.columns where table_schema = 'public' and table_name = '$st';";
$self->{parser}->log("CNFParser-> $st", "\n");
$st = $db->prepare($st);
}else{
- $st = $db->prepare("pragma table_info($tbl)");
+ $st = $db->prepare("pragma table_info($tbl_stm)");
}
$st->execute();
while(my @row_info = $st->fetchrow_array()){
$row_info[2] =~ /(\w+)/;
$table_info[@table_info] = [$row_info[1], uc $1 ]
}
- my $t = $tbl; my ($sel,$ins,@spec,$q,$qinto);
- $t = %$map{$t} if $map && %$map{$t};
- if(ref($t) eq 'ARRAY'){
- @spec = @$t;
- $t = $spec[0]; shift @spec;
+ my $table = $tbl_stm; my ($sel,$ins,@spec,$q,$qinto);
+ $table = %$map{$table} if $map && %$map{$table};
+ if(ref($table) eq 'ARRAY'){
+ @spec = @$table;
+ $table = $spec[0]; shift @spec;
foreach(@spec){ $q.="\"$_\" == ? and " }
$q =~ s/\sand\s$//;
- $st="SELECT * FROM $tbl WHERE $q;";
+ $st="SELECT * FROM $tbl_stm WHERE $q;";
$self->{parser}->log("CNFParser-> $st\n");
$sel = $db -> prepare($st);
}else{
- my $prime_key = getPrimaryKeyColumnNameWherePart($db, $tbl);
- $st="SELECT * FROM $tbl WHERE $prime_key";
+ my $prime_key = getPrimaryKeyColumnNameWherePart($db, $tbl_stm);
+ $st="SELECT * FROM $tbl_stm WHERE $prime_key";
$self->{parser}->log("CNFParser-> $st\n");
$sel = $db -> prepare($st);
- my @r = $self->selectRecords($db,"select count(*) from $tbl;")->fetchrow_array();
+ my @r = $self->selectRecords($db,"select count(*) from $tbl_stm;")->fetchrow_array();
$hasRecords = 1 if $r[0] > 0
}
}
$qinto =~ s/,$//;
$q =~ s/,$//;
- $ins = $db -> prepare("INSERT INTO $tbl ($qinto)\nVALUES ($q);");
+ $ins = $db -> prepare("INSERT INTO $tbl_stm ($qinto)\nVALUES ($q);");
my $data = $self->{parser} -> {'__DATA__'};
if($data){
- my $data_prp = %$data{$t};
+ my $data_prp = %$data{$table};
if(!$data_prp && $self->{data}){
if(%tables_data_map){
- $data_prp = %$data{$tables_data_map{$t}};
+ $data_prp = %$data{$tables_data_map{$table}};
if(!$data_prp){
- $self->{parser} ->error("Invalid data mapping for table $t -> $tables_data_map{$t}")
+ $self->{parser} ->error("Invalid data mapping for table $table -> $tables_data_map{$table}")
}
}
- $data_prp = %{$self->{data}}{$t} if !$data_prp;
+ $data_prp = %{$self->{data}}{$table} if !$data_prp;
}
if($data_prp){
my @hdr;
- my @header = CNFMeta::_deRefArray($$data_prp->{header}); @header = CNFMeta::_deRefArray($header[0]);
+ my @header = CNFMeta::_deRefArray($$data_prp->{header});
+ @header = CNFMeta::_deRefArray($header[$CNFMeta::TABLE_HEADER{COL_NAMES}]);
my @rows = CNFMeta::_deRefArray($$data_prp->{data});
my $auto_increment=0;
for my $i(0 .. $#header){
$hdr[@hdr]={'_'=>$header[$i],'i'=>$i}
}
- $self->{parser} ->error("Header not set for table -> $t") if ! @hdr;
+ $self->{parser} ->error("Header not set for table -> $table") if ! @hdr;
$db->begin_work();
if($self->{STRICT}&&$v!~/^\d\d\d\d-\d\d-\d\d/){
$self-> warn("Invalid date format: $v expecting -> YYYY-MM-DD at start as possibility of DD-MM-YYYY or MM-DD-YYYY is ambiguous.")
}
- $v = CNFDateTime::_toCNFDate($v,$TZ) -> toTimestamp()
+ $v = CNFDateTime::_toCNFDate($v,$TZ) -> toDateTimeFormat()
}else{
- $v = CNFDateTime->new({TZ=>$TZ}) -> toTimestamp()
+ $v = CNFDateTime->now({TZ=>$TZ}) -> toDateTimeFormat()
}
}elsif($table_info[$i][1] =~ m/^BOOL/){
$v = CNFParser::_isTrue($v) ?1:0;
}
}
}
- $self->{parser}->log("CNFParser-> Insert into $tbl -> [". join(',', @ins)."]\n");
+ $self->{parser}->log("CNFParser-> Insert into $tbl_stm -> [". join(',', @ins)."]\n");
if($auto_increment){
$auto_increment--;
splice @ins, $auto_increment, 1
}
$db->commit()
}else{
- $self->{parser}->log("CNFParser-> No data collection is available or mapped to $tbl\n");
+ $self->{parser}->log("CNFParser-> No data collection is available or mapped to $tbl_stm\n");
}
}else{
- $self->{parser}->log("CNFParser-> No data collection scanned for $tbl\n");
+ $self->{parser}->log("CNFParser-> No data collection scanned for $tbl_stm\n");
}
}
foreach my $view(keys %views){
- if(!$curr_tables{$view}){
+ if(!$schema_tables{$view}){
$st = $views{$view};
$self->{parser}->log("CNFParser-> SQL: $st\n");
$db->do($st);
$self->{parser}->log("CNFParser-> Created view: $view\n")
}
}
- undef %tables; undef %tables_id_type;
+ undef %tables_creat_stmts; undef %tables_id_type;
undef %views;
}
catch{
$tables_id_type{$name} = $idType;
return;
}
- $tables{$name} = "CREATE TABLE $name(\n$body);";
+ $tables_creat_stmts{$name} = "CREATE TABLE $name(\n$body);";
$tables_id_type{$name} = $idType;
}
sub createView { my ($self, $name, $body) = @_;
return scalar(@r);
}
-sub getPrimaryKeyColumnNameWherePart { my ($db,$tbl) = @_; $tbl = lc $tbl;
+sub getPrimaryKeyColumnNameWherePart { my ($db,$tbl_stm) = @_; $tbl_stm = lc $tbl_stm;
my $sql = $isPostgreSQL ?
qq(SELECT a.attname, format_type(a.atttypid, a.atttypmod) AS data_type
FROM pg_index i
JOIN pg_attribute a ON a.attrelid = i.indrelid
AND a.attnum = ANY(i.indkey)
-WHERE i.indrelid = '$tbl'::regclass
+WHERE i.indrelid = '$tbl_stm'::regclass
AND i.indisprimary;) :
-qq(PRAGMA table_info($tbl););
+qq(PRAGMA table_info($tbl_stm););
my $st = $db->prepare($sql); $st->execute();
my @r = $st->fetchrow_array();
if(!@r){
- CNFSQLException->throw(error=> "Table missing or has no Primary Key -> $tbl", show_trace=>1);
+ CNFSQLException->throw(error=> "Table missing or has no Primary Key -> $tbl_stm", show_trace=>1);
}
- if($isPostgreSQL){
- return "\"$r[0]\"=?";
- }else{
- # sqlite
- # cid[0]|name|type|notnull|dflt_value|pk<--[5]
- while(!$r[5]){
- @r = $st->fetchrow_array();
- if(!@r){
- CNFSQLException->throw(error=> "Table has no Primary Key -> $tbl", show_trace=>1);
- }
+ if($isPostgreSQL){
+ return "\"$r[0]\"=?";
+ }else{
+ # sqlite
+ # cid[0]|name|type|notnull|dflt_value|pk<--[5]
+ while(!$r[5]){
+ @r = $st->fetchrow_array();
+ if(!@r){
+ CNFSQLException->throw(error=> "Table has no Primary Key -> $tbl_stm", show_trace=>1);
}
- return $r[1]."=?";
}
+ return $r[1]."=?";
+ }
+}
+###
+sub selectCNFConfigRecords {
+ my ($self, $db) = @_;
+ my %ret;
+ try{
+ my $pst = $db->prepare('SELECT NAME, VALUE, DESCRIPTION FROM CNF_CONFIG ORDER BY NAME;');
+ $pst -> execute();
+ while(my @row = $pst->fetchrow_array()){
+ $ret{$row[0]} = \[$row[1], $row[2]]
+ }
+ return \%ret;
+ }catch{
+ CNFSQLException->throw(error=>"Database error encountered!\n ERROR->$@\n", show_trace=>1);
+ }
+
+}
+###
+sub updateCNFConfigRecord {
+ my ($self, $db, $name, $value) = @_;
+ try{
+ $db -> do("UPDATE CNF_CONFIG SET VALUE = '$value' WHERE NAME == '$name';");
+
+ }catch{
+ CNFSQLException->throw(error=>"Database error encountered!\n ERROR->$@\n", show_trace=>1);
+ }
+
}
sub selectRecords {
}
try{
my $pst = $db->prepare($sql);
- return 0 if(!$pst);
+ return 0 if not $pst;
$pst->execute();
return $pst;
}catch{
}
}
#@deprecated
-sub tableExists { my ($self, $db, $tbl) = @_;
+sub tableExists { my ($self, $db, $tbl_stm) = @_;
try{
- $db->do("select count(*) from $tbl;");
+ $db->do("select count(*) from $tbl_stm;");
return 1;
}catch{}
return 0;
}
sub END {
-undef %tables;undef %views;
+undef %tables_creat_stmts;undef %views;
}
1;
+++ /dev/null
-package DatabaseCentralPlugin;
-
-use strict;
-use warnings;
-
-use feature qw(signatures);
-use Scalar::Util qw(looks_like_number);
-use Time::Piece;
-use DBI;
-use Exception::Class ('PluginException');
-use Syntax::Keyword::Try;
-use Clone qw(clone);
-
-
-my ($isSQLite,%tables,$dsn)=(0,());
-
-sub new ($class, $plugin){
- my $settings;
- if($plugin){
- $settings = clone $plugin; #clone otherwise will get hijacked with blessings.
- }
- return bless $settings, $class
-}
-sub getConfigFiles($self, $parser, $property){
- my @dirs = $parser->property($property);
- my @hdr = ['ID','path','size','lines','modified']; my $cnt=0; #We have to mimic CNF<DATA> type entries.
- 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
- }
- }
- our @spec = [
- $CNFMeta::CNF_DATA_TYPES{INT},
- $CNFMeta::CNF_DATA_TYPES{TEXT},
- $CNFMeta::CNF_DATA_TYPES{NUMBER},
- $CNFMeta::CNF_DATA_TYPES{NUMBER},
- $CNFMeta::CNF_DATA_TYPES{DATE}
- ];
- $parser-> data() -> {$self->{element}} = \{
- name=>$property,
- header=>\[\@hdr,"","",\@spec],
- auto=>0,
- data=>\@files
- }
-}
-###
-sub connectDB($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){
- my $db;
- if($property eq '*'){
- foreach my $key(%{$parser->SQL()}){
- my $sql = $parser->SQL()->{$key};
- next if($key eq 'parser');
- $db = connectDB($self,undef,undef) if !$db;
- executePropertyStatement($self,$parser,$db,$key,$sql);
- }
- }else{
- executePropertyStatement($self,$parser,$db,$property,$parser->SQL()->{$property});
- }
-}
-sub executePropertyStatement($self,$parser,$db,$key,$sql){
- $db = connectDB($self,undef,undef) if !$db;
- my $pst = $parser->SQL()->selectRecords($db,$sql);
- if(!$pst){
- $parser->error("Failed to prepare statment -> $sql")
- }else{
- my @data;
- while(my @row = $pst->fetchrow_array()){
- $data[@data] = \@row;
- }
- my @spec;
- my @hdr =[];
- 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.
- @hdr = CNFMeta::_metaTranslateDataHeader($isSQLite,@cols);
- }
- my $table = {
- name=>$key,
- header=>\[\@hdr,"","",\@spec],
- auto=>0,
- data=>\@data
- };
- $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 $item = $parser->anon($property);
- die "Property not found [$property]!" if !$item;
- my ($db);
- try{
- $db = connectDB($self,undef,undef);
- if($isSQLite){
- my $pst = $db->prepare("SELECT name FROM sqlite_master WHERE type='table' or type='view';");
- die if !$pst;
- $pst->execute();
- while(my @r = $pst->fetchrow_array()){
- $tables{$r[0]} = 1;
- }
- }else{
- my @tbls = $db->tables(undef, 'public');
- foreach (@tbls){
- my $t = uc substr($_,7); # We check for tables in uc.
- $tables{$t} = 1;
- }
- }
- }catch{
- PluginException->throw(error=>"<p>Error->$@</p><br><pre>DSN: $dsn</pre>", show_trace=>1);
- }
- my $ref = ref($item);
- if($ref eq 'CNFNode'){
- my @tables = @{$item -> find('table/*')};
- warn "Not found any 'table/*' path elements for CNF property :". $item->name() if not @tables;
-###
- foreach my $tbl(@tables){
- if(processTable($db,$tbl)){
- if($tbl -> {property}){
- my $table = $parser->data()->{$tbl -> {property}};
- my $dbsTblInsert = $db->prepare($tbl -> {sqlInsert});
- my $ptr = $$table->{header};
- my $ref = ref($ptr);
- my @header;
- if($ref eq 'REF'){
- $ptr = $$ptr;
- @header = @$ptr;
- }elsif($ref eq 'ARRAY'){
- @header = @$ptr;
- }
- if(@header==0){
- die "Table data header not established for $property->\[".$tbl->{property}."] has it been DataProcessorPlugin processed?";
- }
-###
- my @idx = ();
- my @map = CNFMeta::_deRefArray($tbl -> {_MAPPING_});
- my @hdr = CNFMeta::_deRefArray($header[0]);
- my @spec = CNFMeta::_deRefArray($header[3]);
-
-
- ###
- # 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.
- #
- if(@hdr){
- for(my $i=0; $i<@hdr; $i++){
- my $label = $hdr[$i];
- my $j=0; my $found =0;
- foreach (@map){
- my @set = @$_;
- if($set[0] =~ m/^$label/i){
- $idx[$j] = $i if $set[1] ne 'auto';
- $found=1;
- last
- }
- $j++
- }
- if ($found==0 && $label ne 'ID'){
- warn "[$label] for table -> ".$tbl -> {name}." not found data header mapped label."
- }
- }
- }
- ###
- my @data = @{$$table->{data}};
- foreach (@data){
- my @row = @{$_};
- my @insert = @idx;
- for(my $i=0; $i<@idx; $i++){
- $insert[$i] = $row[$idx[$i]] if $idx[$i] < @row
- }
- try {
- $dbsTblInsert->execute(@insert)
- }catch{
- PluginException->throw(error=>"\n<p>Error->$@</p><br><pre>property: $property\[".$tbl->{name}."] ->@insert</pre>", show_trace=>1);
- }
- }
- ###
- }
- }
- }
- }
- $db->disconnect();
- $parser->data()->{$property} = [$self];
-}
-
-sub processTable ($db, $node) {
- unless (exists $tables{$node->{name}}) {
- my $sqlCreateTable = "CREATE TABLE ".$node->{name}."(";
- my $sqlInsert = "INSERT INTO ".$node->{name}." ("; my $sqlVals;
- my @columns = @{$node->find('cols/@@')};
- warn "Not found any 'cols/@@' path elements for CNF node :". $node->name() if not @columns;
- my $primary_key;
- for(my $i=0;$i<@columns;$i++){
- my $col = $columns[$i];
- my ($n,$v) = ($col->val() =~ /\s*(.*?)\s+(.*)/);
- if($v =~ /^auto/){
- if( $isSQLite ){
- $v = "integer primary key autoincrement"
- }else{
- $v = "INT UNIQUE GENERATED ALWAYS AS IDENTITY";
- $primary_key = $n;
- }
- splice(@columns,$i--,1);
- }else{
- if($v =~ /^datetime/){
- if( $isSQLite ){
- $v = "TEXT"
- }else{
- $v = "TIMESTAMP";
- }
- }else{
- $v =~ s/\s*$//;
- }
- $sqlInsert .= "$n,"; $sqlVals .= "?,";
- $columns[$i] = [$n,$v];
- }
- $sqlCreateTable .= "$n $v,\n";
- }
- $sqlCreateTable .= "PRIMARY KEY($primary_key)" if $primary_key;
- $sqlCreateTable =~ s/,$//; $sqlInsert =~ s/,$//; $sqlVals =~ s/,$//;
- $sqlCreateTable .= ");"; $sqlInsert .= ") VALUES ($sqlVals);";
- $node->{sqlCreateTable} = $sqlCreateTable;
- $node->{sqlInsert} = $sqlInsert;
- $node->{_MAPPING_} = \@columns;
- $tables{$node->{name}} = $node;
- $db->do($sqlCreateTable);
- return 1;
- }
- return 0;
-}
-
-
-sub zero_prefix ($times, $val) {
- return '0'x$times.$val;
-}
-sub matchType($type, $val, @rows) {
- if ($type==1 && looks_like_number($val)){return 1}
- elsif($type==2){
- if($val=~/\d*\/\d*\/\d*/){return 1}
- else{
- return 1;
- }
- }
- elsif($type==3){return 1}
- return 0;
-}
-
-1;
\ No newline at end of file
lifelog.hopto.org / PerlCNF.git / commitdiff