use strict;
use warnings;
use Exception::Class ('CNFParserException');
-use Try::Tiny;
-use Switch;
+use Syntax::Keyword::Try;
-our $VERSION = '2.0';
+our $VERSION = '2.2';
-
-
-our %anons = ();
our %consts = ();
our %mig = ();
our @sql = ();
our @files = ();
our %tables = ();
+our %views = ();
our %data = ();
our %lists = ();
+our %anons = ();
+our %properties = ();
-sub new {
- my $class = shift;
- my $path = shift;
- my $self = {};
+sub new { my ($class, $path, $attrs, $self) = @_;
+
+ if ($attrs){
+ $self = \%$attrs;
+
+ }else{
+ $self = {"DO_enabled"=>0}; # Enable/Disable DO instruction.
+ }
+
bless $self, $class;
$self->parse($path) if($path);
return $self;
}
-sub anons {
+sub anon {
my ($self, $n, @arg)=@_;
if($n){
my $ret = $anons{$n};
- return undef if !$ret;
+ return if !$ret;
if(@arg){
my $cnt = 1;
foreach(@arg){
return %anons;
}
sub constant {my $s=shift;if(@_ > 0){$s=shift;} return $consts{$s}}
-sub constants {my @ret = sort keys %consts; return @ret}
-sub SQLStatments {return @sql}
-sub dataFiles {return @files}
-sub tables {return keys %tables}
-sub tableSQL {my $t=shift;if(@_ > 0){$t=shift;} return $tables{$t}}
-sub dataKeys {return keys %data}
-sub data {my $t=shift;if(@_ > 0){$t=shift;} return @{$data{$t}}}
-sub migrations {return %mig;}
-sub lists {return \%lists}
-sub list {my $t=shift;if(@_ > 0){$t=shift;} return @{$lists{$t}}}
+sub constants {return \%consts}
+
+sub collections {\%properties}
+sub collection {my($self, $attr)=@_;return $properties{$attr}}
+
sub listDelimit {
- my ($this, $d , $t)=@_;
- my @p = @{$lists{$t}};
- if(@p&&$d){
- my @ret = ();
- foreach (@p){
- my @s = split $d, $_;
- push @ret, @s;
- }
- $lists{$t}=\@ret;
- return @{$lists{$t}};
- }
- return;
-
+ my ($this, $d , $t)=@_;
+ my @p = @{$lists{$t}};
+ if(@p&&$d){
+ my @ret = ();
+ foreach (@p){
+ my @s = split $d, $_;
+ push @ret, @s;
+ }
+ $lists{$t}=\@ret;
+ return @{$lists{$t}};
}
+ return;
+}
+sub lists {\%lists}
+sub list {my $t=shift;if(@_ > 0){$t=shift;} return @{$lists{$t}}}
+
+
+our %curr_tables = ();
+our $isPostgreSQL = 0;
+
+sub isPostgreSQL{shift; $isPostgreSQL}# Enabled here to be called externally.
+my %RESERVED_WORDS = (CONST=>1, DATA=>1, FILE=>1, TABLE=>1,
+ INDEX=>1, VIEW=>1, SQL=>1, MIGRATE=>1, DO=>1, MACRO=>1 );
+sub isReservedWord {if(defined $_[1]){$RESERVED_WORDS{$_[1]}?1:0}}
# Adds a list of environment expected list of variables.
# This is optional and ideally to be called before parse.
sub template {
- my ($self, $property, %macros) = @_;
+ my ($self, $property, %macros) = @_;
my $val = anons($self, $property);
- if($val){
- my $m;
- foreach $m(keys %macros){
+ if($val){
+ foreach my $m(keys %macros){
my $v = $macros{$m};
$m ="\\\$\\\$\\\$".$m."\\\$\\\$\\\$";
$val =~ s/$m/$v/gs;
# print $val;
}
my $prev;
- foreach $m(split(/\$\$\$/,$val)){
+ foreach my $m(split(/\$\$\$/,$val)){
if(!$prev){
$prev = $m;
next;
}
return $val;
}
- return undef;
+ return;
}
sub parse {
my ($self, $cnf, $content) = @_;
- open(my $fh, "<:perlio", $cnf ) or CNFParserException->throw("Can't open $cnf -> $!");
+try{
+ my $DO_enabled = $self->{'DO_enabled'};
+ my %instructs;
+ if(!$content){
+ open(my $fh, "<:perlio", $cnf ) or die "Can't open $cnf -> $!";
read $fh, $content, -s $fh;
close $fh;
-try{
-
- my @tags = ($content =~ m/<<(\$*\w*\$*<(.*?).*?>+)/gs);
-
+ }
+ my @tags = ($content =~ m/(<<)(<*.*?)(>>+)/gms);
+
foreach my $tag (@tags){
- next if not $tag;
- if(index($tag,'<CONST')==0){#constant multiple properties.
+ next if not $tag;
+ next if $tag =~ m/^(>+)|^(<<)/;
+ if($tag=~m/^<CONST/){#constant multiple properties.
foreach (split '\n', $tag){
- my @prps = map {
- s/^\s+\s+$//; # strip unwanted spaces
- s/^\"//; # strip start quote
- s/\"$//; # strip end quote
- s/<const\s//i; # strip identifier
+ my $k;#place holder trick for split.
+ my @properties = map {
+ s/^\s+|\s+$//; # strip unwanted spaces
+ s/^\s*["']|['"]\s*$//g;#strip qoutes
+ s/<CONST\s//; # strip identifier
s/\s>>//;
- $_ # return the modified string
- }
- split /\s*=\s*/, $_;
-
- my $k;
- foreach (@prps){
+ $_ # return the modified string
+ } split /\s*=\s*/, $_;
+ foreach (@properties){
if ($k){
$consts{$k} = $_ if not $consts{$k};
undef $k;
}
}
- }
- elsif(index($tag,'CONST<')==0){#single property multiline constant.
- my $i = index $tag, "\n";
- my $k = substr $tag, 6, $i-6;
- my $v = substr $tag, $i, (rindex $tag, ">>")-$i;
- $consts{$k} = $v if not $consts{$k};
- }
+ }
else{
+ my ($st,$e,$t,$v, $v3, $i) = 0;
+ my @vv = ($tag =~ m/(@|[\$@%]*\w*)(<|>)/g);
+ $e = $vv[$i++]; $e =~ s/^\s*//g;
+ die "Encountered invalid tag formatation -> $tag" if(!$e);
+ # Is it <name><tag>value? Notce here, we are using here perls feature to return undef on unset array elements,
+ # other languages throw exception. And reg. exp. set variables. So the folowing algorithm is for these languages unusable.
+ while(defined $vv[$i] && $vv[$i] eq '>'){ $i++; }
+ $i++;
+ $t = $vv[$i++];
+ $v = $vv[$i++];
+ if(!$v&&!$t&& $tag =~ m/(.*)(<)(.*)/g){# Maybe it is the old format wee <<{name}<{instruction} {value}...
+ $t = $1; if (defined $3){$v3 = $3}else{$v3 = ""} $v = $v3;
+ my $w = ($v=~/(^\w+)/)[0];
+ if(not defined $w){$w=""}
+ if($e eq $t && $t eq $w){
+ $i=-1;$t="";
+ }elsif($RESERVED_WORDS{$w}){
+ $t = $w;
+ $i = length($e) + length($w) + 1;
+ }else{
+ if($v3){$i=-1;$t=$v} #$3 is containing the value, we set the tag to it..
+ else{
+ $i = length($e) + 1;
+ }
+ }
+ $v = substr $tag, $i if $i>-1; $v3 = '_V3_SET';
+
+ }elsif (!$t && $v =~ /[><]/){ #it might be {tag}\n closed, as supposed to with '>'
+ my $l = length($e);
+ $i = index $tag, "\n";
+ $t = substr $tag, $l + 1 , $i -$l - 1;
+ $v3 = '_SUBS1_SET';
+ }else{
+ $i = length($e) + length($t) + ($i - 3);
+ $v3 = '_SUBS2_SET';
+ }
- my ($st,$v);
- my @kv = split /</,$tag;
- my $e = $kv[0];
- my $t = $kv[1];
- my $i = index $t, "\n";
#trim accidental spacing in property value or instruction tag
$t =~ s/^\s+//g;
- if((@kv)==2 && $t =~ m/\w>$/){ # arbitary instructed and values
- $i = index $content, $tag;
- $i = $i + length($tag);
- $st = index $content, ">>", $i;
- if($st==-1){$st = index $content, "<<", $i}#Maybe still in old format CNF1.0
- if(substr($content, $i,1)eq'\n'){$i++}#value might be new line steped?
- $v = substr $content, $i, $st - $i ;
-
- $anons{$e} = "<$t"."\n".$v;
- next;
- }
- #TODO This section is problematic, a instruction is not the value of the property. Space is after the instruction on single line.
- if($i==-1){#It is single line
- my $te = index $t, " ";
- if($te>0){
- $v = substr($t, $te+1, (rindex $t, ">>")-($te+1));
- if(isReservedWord($v)){
- $t = substr($t, 0, $te);
+ # Here it gets tricky as rest of markup in the whole $tag could contain '<' or '>' as text characters, usually in multi lines.
+ $v = substr $tag, $i if $v3 ne '_V3_SET';
+ $v =~ s/^[><\s]*//g if $v3 ne '_SUBS1_SET';
+
+ # print "<<$e>>\nt:<<$t>>\nv:<<$v>>\n\n";
+
+ if($e eq '@'){#collection processing.
+ my $isArray = $t=~ m/^@/;
+ my @lst = ($isArray?split(/[,\n]/, $v):split('\n', $v)); $_="";
+ my @props = map {
+ s/^\s+|\s+$//; # strip unwanted spaces
+ s/^\s*["']|['"]$//g;#strip qoutes
+ s/\s>>//;
+ $_ ? $_ : undef # return the modified string
+ } @lst;
+ if($isArray){
+ my @arr=(); $properties{$t}=\@arr;
+ foreach (@props){
+ push @arr, $_ if( length($_)>0);
+ }
+ }else{
+ my %hsh=(); $properties{$t}=\%hsh; my $macro = 0;
+ foreach my $p(@props){
+ if($p eq 'MACRO'){$macro=1}
+ elsif( $p && length($p)>0 ){
+ my @pair = split(/\s*=\s*/, $p);
+ die "Not '=' delimited-> $p" if scalar( @pair ) != 2;
+ my $name = $pair[0]; $name =~ s/^\s*|\s*$//g;
+ my $value = $pair[1]; $value =~ s/^\s*["']|['"]$//g;#strip qoutes
+ if($macro){
+ foreach my $find($v =~ /(\$.*\$)/g) {
+ my $s= $find; $s =~ s/^\$\$\$|\$\$\$$//g;
+ my $r = $anons{$s};
+ $r = $consts{$s} if !$r;
+ $r = $instructs{$s} if !$r;
+ die "Unable to find property for $t.$name -> $find\n" if !$r;
+ $value =~ s/\Q$find\E/$r/g;
+ }
+ }
+ $hsh{$name}=$value;
+ }
}
- else{
- $v = $t =substr $t, 0, (rindex $t, ">>");#single line declared anon most likely.
- }
- }
- else{
- my $ri = (rindex $t, ">>>");
- $ri = (rindex $t, ">>") if($ri==-1);
- $t = $v = substr $t, 0, $ri;
}
- }
- else{
- my $ri = (rindex $t, ">>>");
- $ri = (rindex $t, ">>") if($ri==-1);
- #print "[[1[$t]]]\n";
- if($ri>$i){
- $v = substr $t, $i;
- #opting to trim on multilines, just in case number of ending "<<" count is scripted in a mismatch!
- $v =~ s/\s*>+$//g;
- # print "[[2[$e->$v]]\n";
- }
- else{
- $v = substr $t, $i+1, $ri - ($i+2);
- }
- $t = substr $t, 0, $i;
- }
-
- # print "Ins($i): with $e do $t|\n";
-
+ next;
+ }
- if($t eq 'CONST'){#Single constant with mulit-line value;
+ if($t eq 'CONST'){#Single constant with mulit-line value;
$v =~ s/^\s//;
- $consts{$e} = $v if not $consts{$e};
- next;
- }
- elsif($t eq 'DATA'){
+ $consts{$e} = $v if not $consts{$e}; # Not allowed to overwrite constant.
+ }elsif($t eq 'DATA'){
$st ="";
my @tad = ();
foreach(split /~\n/,$v){
- my $d = $i = "";
- $_ =~ s/\\`/\\f/g;#We escape to form feed the escaped in file backtick.
- foreach $d (split /`/, $_){
+ my $i = "";
+ $_ =~ s/\\`/\\f/g;#We escape to form feed the found 'escaped' backtick so can be used as text.
+ foreach my $d (split /`/, $_){
$d =~ s/\\f/`/g; #escape back form feed to backtick.
$t = substr $d, 0, 1;
if($t eq '$'){
else{
#First is always ID a number and '#' signifies number.
if($t eq "\#") {
- $i .= "$d," if $d;
+ $d = substr $d, 1;
+ $d=0 if !$d; #default to 0 if not specified.
+ $i .= "$d,"
}
else{
- $i .= "'$d',";
+ $i .= "$d,";
}
}
}
my @existing = $data{$e};
if(scalar(@existing)>1){
@existing = @{$data{$e}};
- foreach $i(@existing){
+ foreach my $i(@existing){
push @tad, $i if $i;
}
}
$data{$e} = [@tad] if scalar(@tad)>0;
next;
- }
- elsif($t eq 'FILE'){
+ }elsif($t eq 'FILE'){
- my $path = $cnf;
+ my ($i,$path) = $cnf;
$v=~s/\s+//g;
$path = substr($path, 0, rindex($cnf,'/')) .'/'.$v;
push @files, $path;
my @tags = ($content =~ m/<<(\w*<(.*?).*?>>)/gs);
foreach my $tag (@tags){
next if not $tag;
- @kv = split /</,$tag;
+ my @kv = split /</,$tag;
$e = $kv[0];
$t = $kv[1];
$i = index $t, "\n";
$st ="";
my @tad = ();
foreach(split /~\n/,$v){
- my $d = $i = "";
+ my $i = "";
$_ =~ s/\\`/\\f/g;#We escape to form feed the escaped in file backtick.
- foreach $d (split /`/, $_){
+ foreach my $d (split /`/, $_){
$d =~ s/\\f/`/g; #escape back form feed to backtick.
$t = substr $d, 0, 1;
if($t eq '$'){
my @existing = $data{$e};
if(scalar(@existing)>1){
@existing = @{$data{$e}};
- foreach $i(@existing){
+ foreach my $i(@existing){
push @tad, $i if $i;
}
}
next;
}
elsif($t eq 'TABLE'){
- $st = "CREATE TABLE $e(\n$v\n);";
+ $st = "CREATE TABLE $e(\n$v);";
$tables{$e} = $st;
next;
}
$st = "CREATE INDEX $v;";
}
elsif($t eq 'VIEW'){
- $st = "CREATE VIEW $v;";
+ $st = "CREATE VIEW $e AS $v;";
+ $views{$e} = $st;
+ next;
}
elsif($t eq 'SQL'){
- $st = $v;
+ $anons{$e} = $v;
}
elsif($t eq 'MIGRATE'){
my @m = $mig{$e};
push @m, $v;
$mig{$e} = [@m];
}
+ elsif($DO_enabled && $t eq 'DO'){
+ $anons{$e} = eval $v;
+ }
+ elsif($t eq 'MACRO'){
+ %instructs = () if(not %instructs);
+ $instructs{$e}=$v;
+ }
else{
- #Register application statement as either an anonymouse one. Or since v.1.2 an listing type tag.
- #print "Reg($e): $v\n";
- if($e !~ /\$\$$/){ $anons{$e} = $v }
+ #Register application statement as either an anonymouse one. Or since v.1.2 an listing type tag.
+ if($e !~ /\$\$$/){ #<- It is not matching {name}$$ here.
+ if($e=~/^\$/){
+ $consts{$e} = $v if !$consts{$e}; # Not allowed to overwrite constant.
+ }else{
+ if(defined $t && length($t)>0){ #unknow tagged instructions value we parse for macros.
+ %instructs = () if(not %instructs);
+ $instructs{$e}=$t;
+ }else{
+ $anons{$e} = $v # It is allowed to overwite and abuse anons.
+ }
+ }
+ }
else{
- $e = substr $e, 0, (rindex $e, "$$")-1;
+ $e = substr $e, 0, (rindex $e, '$$')-1;
# Following is confusing as hell. We look to store in the hash an array reference.
- # But must convert back and fort via an scalar, since actual arrays returned from an hash are copies in perl.
+ # But must convert back and fort via an scalar, since actual arrays returned from an hash are references in perl.
my $a = $lists{$e};
if(!$a){$a=();$lists{$e} = \@{$a};}
push @{$a}, $v;
- #print "Reg($e): $v [$a]\n";
-
}
next;
}
push @sql, $st;#push as application statement.
}
- }
-
+ }
+ if(%instructs){ my $v;
+ foreach my $e(keys %instructs){
+ my $t = $instructs{$e}; $v=$t; #<--Instructions assumed as a normal value, case: <<{name}<{instruction}>>>
+ foreach my $find($t =~ /(\$.*\$)/g) {
+ my $s= $find; $s =~ s/^\$\$\$|\$\$\$$//g;
+ my $r = $anons{$s};
+ $r = $consts{$s} if !$r;
+ die "Unable to find property for $e-> $find\n" if !$r;
+ $v = $t;
+ $v =~ s/\Q$find\E/$r/g;
+ $t = $v;
+ }
+ $anons{$e}=$v;
+ }undef %instructs;
+ }
}catch{
- CNFParserException->throw(error=>$_, show_trace=>1);
-};
+ CNFParserException->throw(error=>$@, show_trace=>1);
}
-
-sub isReservedWord {
- my $word = shift;
- switch($word){
- case "DATA" { return 1; } case "FILE" { return 1; } case "TABLE" { return 1; } case "INDEX" { return 1; }
- case "VIEW" { return 1; } case "SQL" { return 1; } case "MIGRATE" { return 1; }
- }
- return 0;
}
##
# Required to be called when using CNF with an database based storage.
+# This subrotine is also a good example why using generic driver is not recomended.
+# Various SQL db server flavours meta info is def. handled differently and not updated in them.
#
sub initiDatabase {
- my($self,$db,$st,$dbver)=@_;
-#Check and set SYS_CNF_CONFIG
+ my($self,$db,$do_not_auto_synch)=@_;
+ my $st = shift;
+ my $dbver = shift;
+
+#Check and set CNF_CONFIG
try{
- $st=$db->do("select count(*) from SYS_CNF_CONFIG;");
- $st = $db->prepare('SELECT VALUE FROM SYS_CNF_CONFIG WHERE NAME LIKE "$RELEASE_VER";');
- $st->execute();
- my @r = $st->fetchrow_array();
- $dbver = $r[0];
-}
-catch{
- # $st = $db->prepare('SELECT VALUE FROM SYS_CNF_CONFIG WHERE NAME LIKE "$RELEASE_VER";');
- # $st->execute() or warn "Missing!";
- # my @r = $st->fetchrow_array();
- # return $r[0] if(@r);
-
- print "Missing SYS_CNF_CONFIG table, trying next to create it.\n";
- my $stmt = qq(
- CREATE TABLE SYS_CNF_CONFIG (
+
+ $isPostgreSQL = $db-> get_info( 17) eq 'PostgreSQL';
+
+ if($isPostgreSQL){
+ my @tbls = $db->tables(undef, 'public'); #<- This is the proper way, via driver, doesn't work on sqlite.
+ foreach (@tbls){
+ my $t = uc substr($_,7); $t =~ s/^["']|['"]$//g;
+ $curr_tables{$t} = 1;
+ }
+ }
+ else{
+ my $pst = selectRecords($self, $db, "SELECT name FROM sqlite_master WHERE type='table' or type='view';");
+ while(my @r = $pst->fetchrow_array()){
+ $curr_tables{$r[0]} = 1;
+ }
+ }
+
+ if(!$curr_tables{CNF_CONFIG}){
+ my $stmt;
+ if($isPostgreSQL){
+ $stmt = qq|
+ CREATE TABLE CNF_CONFIG
+ (
+ NAME character varying(16) NOT NULL,
+ VALUE character varying(128) NOT NULL,
+ DESCRIPTION character varying(256),
+ CONSTRAINT CNF_CONFIG_pkey PRIMARY KEY (NAME)
+ )|;
+ }else{
+ $stmt = qq|
+ CREATE TABLE CNF_CONFIG (
NAME VCHAR(16) NOT NULL,
- VALUE VCHAR(28) NOT NULL,
- DESCRIPTION VCHAR(128)
- );
- );
- $db->do($stmt);
- print "Created table: SYS_CNF_CONFIG \n";
- $st = $db->prepare('INSERT INTO SYS_CNF_CONFIG VALUES(?,?,?);');
+ VALUE VCHAR(128) NOT NULL,
+ DESCRIPTION VCHAR(256)
+ )|;
+ }
+ $db->do($stmt);
+ print "CNFParser-> Created CNF_CONFIG table.";
+ $st = $db->prepare('INSERT INTO CNF_CONFIG VALUES(?,?,?);');
$db->begin_work();
foreach my $key($self->constants()){
my ($dsc,$val);
$st->execute($key,$val,$dsc);
}
$db->commit();
- $dbver = $self -> constant('$RELEASE_VER');
-};
-
-return $dbver;
-
+ }else{
+ my $sel = $db->prepare('SELECT VALUE FROM CNF_CONFIG WHERE NAME LIKE ?;');
+ my $ins = $db->prepare('INSERT INTO CNF_CONFIG VALUES(?,?,?);');
+ foreach my $key(sort keys %{$self->constants()}){
+ my ($dsc,$val);
+ $val = $self->constant($key);
+ my @sp = split '`', $val;
+ if(scalar @sp>1){$val=$sp[0];$dsc=$sp[1];}else{$dsc=""}
+ $sel->execute($key);
+ if(!$sel->fetchrow_array()){
+ $ins->execute($key,$val,$dsc);
+ }
+ }
+ }
+ # By default we automatically data insert synchronize script with database state on every init.
+ # If set $do_not_auto_synch = 1 we skip that if table is present, empty or not,
+ # and if has been updated dynamically that is good, what we want. It is of external config. implementation choice.
+ foreach my $tbl(keys %tables){
+ if(!$curr_tables{$tbl}){
+ $st = $tables{$tbl};
+ print "CNFParser-> SQL: $st\n";
+ $db->do($st);
+ print "CNFParser-> Created table: $tbl\n";
+ }
+ else{
+ next if $do_not_auto_synch;
+ }
+ if(isPostgreSQL()){
+ $st = lc $tbl; #we lc, silly psql is lower casing meta and case sensitive for internal purposes.
+ $st="select column_name, data_type from information_schema.columns where table_schema = 'public' and table_name = '$st';";
+ print "CNFParser-> $st", "\n";
+ $st = $db->prepare($st);
+ }else{
+ $st = $db->prepare("pragma table_info($tbl)");
+ }
+ $st->execute();
+ my $q =""; my @r;
+ while(@r=$st->fetchrow_array()){ $q.="?,"; } $q =~ s/,$//;
+ my $ins = $db->prepare("INSERT INTO $tbl VALUES($q);");
+ $st="SELECT * FROM $tbl where ".getPrimaryKeyColumnNameWherePart($db, $tbl);
+ print "CNFParser-> $st\n";
+ my $sel = $db->prepare($st);
+ @r = data($tbl);
+ $db->begin_work();
+ foreach my $rs(@r){
+ my @cols=split(',',$rs);
+ # If data entry already exists in database, we skip and don't force or implement an update,
+ # as potentially such we would be overwritting possibly changed values, and inserting same pk's is not allowed as they are unique.
+ next if hasEntry($sel, $cols[0]);
+ print "CNFParser-> Inserting into $tbl -> $rs\n";
+ $ins->execute(@cols);
+ }
+ $db->commit();
+ }
+ foreach my $view(keys %views){
+ if(!$curr_tables{$view}){
+ $st = $views{$view};
+ print "CNFParser-> SQL: $st\n";
+ $db->do($st);
+ print "CNFParser-> Created view: $view\n";
+ }
+ }
+ # Following is not been kept no more for external use.
+ undef %tables;
+ undef %views;
+ undef %mig;
+ undef %data;
+}
+catch{
+ CNFParserException->throw(error=>$@, show_trace=>1);
+}
+$self -> constant('$RELEASE_VER');
}
+sub hasEntry{
+ my ($sel, $uid) = @_;
+ $uid=~s/^["']|['"]$//g;
+ $sel->execute($uid);
+ return scalar( $sel->fetchrow_array() );
+}
+sub getPrimaryKeyColumnNameWherePart {
+ my ($db,$tbl) = @_; $tbl = lc $tbl;
+ my $sql = $isPostgreSQL ? qq(SELECT c.column_name, c.data_type
+FROM information_schema.table_constraints tc
+JOIN information_schema.constraint_column_usage AS ccu USING (constraint_schema, constraint_name)
+JOIN information_schema.columns AS c ON c.table_schema = tc.constraint_schema
+ AND tc.table_name = c.table_name AND ccu.column_name = c.column_name
+WHERE constraint_type = 'PRIMARY KEY' and tc.table_name = '$tbl') :
+qq(PRAGMA table_info($tbl););
+my $st = $db->prepare($sql); $st->execute();
+my @r = $st->fetchrow_array();
+if(!@r){
+ CNFParserException->throw(error=> "Table missing or has no Primary Key -> $tbl", show_trace=>1);
+}
+ if($isPostgreSQL){
+ return $r[0]."=?";
+ }else{
+ # sqlite
+ # cid[0]|name|type|notnull|dflt_value|pk<--[5]
+ while(!$r[5]){
+ @r = $st->fetchrow_array();
+ if(!@r){
+ CNFParserException->throw(error=> "Table has no Primary Key -> $tbl", show_trace=>1);
+ }
+ }
+ return $r[1]."=?";
+ }
+}
+sub selectRecords {
+ my ($self, $db, $sql) = @_;
+ if(scalar(@_) < 2){
+ die "Wrong number of arguments, expecting CNFParser::selectRecords(\$db, \$sql) got Settings::selectRecords('@_').\n";
+ }
+ try{
+ my $pst = $db->prepare($sql);
+ return 0 if(!$pst);
+ $pst->execute();
+ return $pst;
+ }catch{
+ CNFParserException->throw(error=>"Database error encountered!\n ERROR->$@\n SQL-> $sql DSN:".$db, show_trace=>1);
+ };
+}
+#@deprecated
sub tableExists {
my ($self, $db, $tbl) = @_;
try{
return 0;
}
+# Writes out to handle an property.
+sub writeOut { my ($self, $handle, $property) = @_;
+ my $prp = $properties{$property};
+ if($prp){
+ print $handle "<<@<$property><\n";
+ if(ref $prp eq 'ARRAY') {
+ my @arr = sort keys @$prp; my $n=0;
+ foreach (@arr){
+ print $handle "\"$_\"";
+ if($arr[-1] ne $_){
+ if($n++>5){print $handle "\n"; $n=0}
+ else{print $handle ",";}
+ }
+ }
+ }elsif(ref $prp eq 'HASH') {
+ my %hsh = %$prp;
+ my @keys = sort keys %hsh;
+ foreach my $key(@keys){
+ print $handle $key . "\t= \"". $hsh{$key} ."\"\n";
+ }
+ }
+ print $handle ">>>\n";
+
+ return 1;
+ }
+ else{
+ $prp = $anons{$property};
+ $prp = $consts{$property} if !$prp;
+ die "Property not found -> $property" if !$prp;
+ print $handle "<<$property><$prp>>\n";
+ return 0;
+ }
+}
+
###
# Closes any buffered files and clears all data for the parser.
# TODO 2020-02-13 Under development.
use constant VW_LOG_OVERRIDE_WHERE => 'VW_LOG_OVR_WHERE';
#DEFAULT SETTINGS HERE!
-our $RELEASE_VER = '2.2';
+our $RELEASE_VER = '2.3';
our $TIME_ZONE = 'Australia/Sydney';
our $LANGUAGE = 'English';
our $PRC_WIDTH = '60';
our $SQL_PUB = undef;
our $TIME_ZONE_MAP ="";
-sub anons {my @ret=sort(keys %anons); return @ret;}
+#The all purpose '$S_' class get/setter variable, we do better with less my new variable assignments.
+our $S_ ="";
+#
+sub anons { keys %anons}
#Check call with defined(Settings::anon('my_anon'))
-sub anon {my $n=shift; return $anons{$n}}
+sub anon {$S_=shift; $S_ = $anons{$S_} if $S_;$S_}
sub anonsSet {my $a = shift;%anons=%{$a}}
-sub release {return $RELEASE_VER}
-sub logPath {return $LOG_PATH}
-sub theme {return $THEME}
-sub language {return $LANGUAGE}
-sub timezone {return $TIME_ZONE}
-sub sessionExprs {return $SESSN_EXPR}
-sub imgWidthHeight {return $IMG_W_H}
-sub pagePrcWidth {return $PRC_WIDTH}
-sub frameSize {return $FRAME_SIZE}
-sub universalDate {return $DATE_UNI;}
-sub recordLimit {return $REC_LIMIT}
-sub autoWordLimit {return $AUTO_WRD_LMT}
-sub autoWordLength {return $AUTO_WRD_LEN}
-sub viewAllLimit {return $VIEW_ALL_LMT}
-sub displayAll {return $DISP_ALL}
-sub trackLogins {return $TRACK_LOGINS}
-sub windowRTFSize {return $RTF_SIZE}
-sub keepExcludes {return $KEEP_EXCS}
-sub bgcol {return $BGCOL}
-sub css {return $TH_CSS}
-sub compressPage {return $COMPRESS_ENC}
-sub debug {my $r = shift; if(!$r){$r = $DEBUG}else{$DEBUG=$r} return $r}
-sub dbSrc {my $r = shift; if($r) {$DBI_SOURCE=$r; $IS_PG_DB = 1 if(index (uc $r, 'DBI:PG') ==0)}
- return $DBI_SOURCE}
-sub dbVLSZ {my $r = shift; if(!$r){$r = $DBI_LVAR_SZ}else{$r=128 if($r<128);$DBI_LVAR_SZ=$r} return $r}
-sub dbFile {my $r = shift; if($r) {$DBFILE=$r} return $DBFILE}
-sub dbName {my $r = shift; if($r) {$dbname=$r} return $dbname}
-sub dsn {return $DSN}
-sub isProgressDB {return $IS_PG_DB}
-sub sqlPubors {return $SQL_PUB}
-
-sub cgi {return $cgi}
-sub session {return $sss}
-sub sid {return $sid}
-sub alias {return $alias}
-sub pass {return $pass}
-sub pub {return $pub}
-
-sub trim {my $r=shift; $r=~s/^\s+|\s+$//g; return $r}
-
+sub release {$RELEASE_VER}
+sub logPath {$S_ = shift;$LOG_PATH = $S_ if $S_;$LOG_PATH}
+sub theme {$THEME}
+sub timezone {$TIME_ZONE}
+sub sessionExprs {$SESSN_EXPR}
+sub imgWidthHeight {$IMG_W_H}
+sub pagePrcWidth {$PRC_WIDTH}
+sub frameSize {$FRAME_SIZE}
+sub universalDate {$DATE_UNI;}
+sub recordLimit {$REC_LIMIT}
+sub autoWordLimit {$AUTO_WRD_LMT}
+sub autoWordLength {$AUTO_WRD_LEN}
+sub viewAllLimit {$VIEW_ALL_LMT}
+sub displayAll {$DISP_ALL}
+sub trackLogins {$TRACK_LOGINS}
+sub windowRTFSize {$RTF_SIZE}
+sub keepExcludes {$KEEP_EXCS}
+sub bgcol {$BGCOL}
+sub css {$TH_CSS}
+sub compressPage {$COMPRESS_ENC}
+sub debug {$S_ = shift; $DEBUG = $S_ if $S_; $DEBUG}
+sub dbSrc {$S_= shift; if($S_) {$DBI_SOURCE=$S_; $IS_PG_DB = 1 if(index (uc $S_, 'DBI:PG') ==0)}
+ $DBI_SOURCE}
+sub dbVLSZ {$S_ = shift; if(!$S_){$S_ = $DBI_LVAR_SZ}else{$S_=128 if($S_<128);$DBI_LVAR_SZ=$S_}}
+sub dbFile {$S_ = shift; $DBFILE = $S_ if $S_; $DBFILE}
+sub dbName {$S_ = shift; $dbname = $S_ if $S_; $dbname}
+sub dsn {$DSN}
+sub isProgressDB {$IS_PG_DB}
+sub sqlPubors {$SQL_PUB}
+
+sub cgi {$cgi}
+sub session {$sss}
+sub sid {$sid}
+sub alias {$alias}
+sub pass {$pass}
+sub pub {$pub}
+
+sub trim {my $r=shift; $r=~s/^\s+|\s+$//g; $r}
+#The following has to be called from an CGI seesions container that provides parameters.
sub fetchDBSettings {
try {
$CGI::POST_MAX = 1024 * 1024 * 5; # max 5GB file post size limit.
- $cgi = CGI->new();
- $sss = new CGI::Session("driver:File", $cgi, {Directory=>$LOG_PATH});
+ $cgi = $cgi = CGI->new();
+ $sss = shift; #shift will only and should, ONLY happen for test scripts.
+ $sss= new CGI::Session("driver:File", $cgi, {Directory=>$LOG_PATH}) if !$sss;
$sid = $sss->id();
$alias = $sss->param('alias');
$pass = $sss->param('passw');
- $pub = $cgi->param('pub');
+ $pub = $cgi->param('pub');$pub = $sss->param('pub') if !$pub; #maybe test script session set, sss.
$dbname = $sss->param('database'); $dbname = $alias if(!$dbname);
##From here we have data source set, currently Progress DB SQL and SQLite SQL compatible.
dbSrc($sss->param('db_source'));
if($pub){#we override session to obtain pub(alias)/pass from file main config.
- open(my $fh, '<', logPath().'main.cnf' ) or LifeLogException->throw("Can't open main.cnf: $!");
+ open(my $fh, '<', logPath().'main.cnf') or LifeLogException->throw("Can't open main.cnf: $!");
while (my $line = <$fh>) {
- chomp $line;
- my $v = parseAutonom('PUBLIC_LOGIN',$line);
- if($v){my @cre = split '/', $v;
+ chomp $line;
+ my $v = parseAutonom('PUBLIC_LOGIN',$line);
+ if($v){my @cre = split '/', $v;
$alias = $cre[0];
$pass = uc crypt $cre[1], hex Settings->CIPHER_KEY;
- }
- $v = parseAutonom('PUBLIC_CATS',$line);
- if($v){my @cats= split(',',$v);
+ }
+ $v = parseAutonom('PUBLIC_CATS',$line);
+ if($v){my @cats= split(',',$v);
foreach(@cats){
$SQL_PUB .= "ID_CAT=".trim($_)." OR ";
}
$SQL_PUB =~ s/\s+OR\s+$//;
- }
- last if parseAutonom('CONFIG',$line);
+ }elsif($line =~ /<<PLUGINS</){
+ $S_ = substr($line, 10);
+ while ($line = <$fh>) {
+ chomp $line;
+ last if($line =~ />$/);
+ $S_ .= $line . "\n";
+ }
+ $anons{'PLUGINS'} = $S_;
+ next;
+ }
+ last if parseAutonom('CONFIG',$line);
}
close $fh;
- if(!$SQL_PUB){$alias=undef}
+ if(!$SQL_PUB&&$pub ne 'test'){$alias=undef}
}
# if(!$alias){
# $alias = "admin"; $pass = $alias; dbSrc('dbi:Pg:host=localhost;');
FOREIGN KEY (CID) REFERENCES CAT(ID)
);
)}
-
+#Selects the actual database set configuration for the application, not from the config file.
sub getConfiguration {
my ($db, $hsh) = @_;
my $fh;
&setTimezone;
}
catch {
- SettingsException->throw(error=>$@, show_trace=>$DEBUG);
+ SettingsException->throw(error=>"DSN:$DSN &getConfiguration.ERR->[$@]", show_trace=>$DEBUG);
};
}
lifelog.hopto.org / LifeLog.git / commitdiff