From 951f52c0d427602a7c15b809d2647935cc02a0c8 Mon Sep 17 00:00:00 2001 From: wbudic Date: Tue, 3 Aug 2021 10:34:47 +1000 Subject: [PATCH] upd. NOT TESTED! --- Current Development Check List.md | 3 +- Installation_ProgresSQL.txt | 2 +- htdocs/cgi-bin/system/modules/CNFParser.pm | 594 ++++++++++++++------- htdocs/cgi-bin/system/modules/Settings.pm | 128 +++-- 4 files changed, 482 insertions(+), 245 deletions(-) diff --git a/Current Development Check List.md b/Current Development Check List.md index 7b8234c..e640b19 100644 --- a/Current Development Check List.md +++ b/Current Development Check List.md @@ -6,7 +6,8 @@ ### New Development -* Update to CNF v.2.2, branch to $RELEASE_VER = 2.3, Earth Stage initial. +* JS - Event, on expense sum in log numbers found at beginning of lines. +* ✔ Update to CNF v.2.2, branch to $RELEASE_VER = 2.3, Earth Stage initial. * Plugins * Perl files enabled by being including them in main.cnf file under the <>> list, and placed in the plugins directory. * This plugin perl file is then be executed, to provide auto installation and checks. diff --git a/Installation_ProgresSQL.txt b/Installation_ProgresSQL.txt index ef933b5..62a8143 100644 --- a/Installation_ProgresSQL.txt +++ b/Installation_ProgresSQL.txt @@ -73,7 +73,7 @@ sudo python3 -m pip install https://ftp.postgresql.org/pub/pgadmin/pgadmin4/v4.3 # Data directory location for backup sudo -u postgres psql -c "SHOW data_directory;" | grep -G / ## Quick tar all -sudo tar ~/czvf postgresql.db.backup.tar $(sudo -u postgres psql -c "SHOW data_directory;" | grep -G /) +sudo tar czvf ~/postgresql.db.backup.tar $(sudo -u postgres psql -c "SHOW data_directory;" | grep -G /) diff --git a/htdocs/cgi-bin/system/modules/CNFParser.pm b/htdocs/cgi-bin/system/modules/CNFParser.pm index 2f6e915..c05759f 100644 --- a/htdocs/cgi-bin/system/modules/CNFParser.pm +++ b/htdocs/cgi-bin/system/modules/CNFParser.pm @@ -8,38 +8,42 @@ package CNFParser; 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){ @@ -52,31 +56,36 @@ sub anons { 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. @@ -98,18 +107,17 @@ sub addENVList { 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; @@ -126,36 +134,37 @@ sub template { } 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,'+)|^(<<)/; + if($tag=~m/^>//; - $_ # 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; @@ -166,82 +175,103 @@ try{ } } - } - 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 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 /$/){ # 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 '$'){ @@ -258,10 +288,12 @@ try{ 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,"; } } } @@ -271,16 +303,15 @@ try{ 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; @@ -291,7 +322,7 @@ try{ my @tags = ($content =~ m/<<(\w*<(.*?).*?>>)/gs); foreach my $tag (@tags){ next if not $tag; - @kv = split /1){ @existing = @{$data{$e}}; - foreach $i(@existing){ + foreach my $i(@existing){ push @tad, $i if $i; } } @@ -349,7 +380,7 @@ try{ next; } elsif($t eq 'TABLE'){ - $st = "CREATE TABLE $e(\n$v\n);"; + $st = "CREATE TABLE $e(\n$v);"; $tables{$e} = $st; next; } @@ -357,10 +388,12 @@ try{ $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}; @@ -368,70 +401,111 @@ try{ 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); @@ -441,14 +515,130 @@ catch{ $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{ @@ -484,6 +674,40 @@ sub readNext(){ 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. diff --git a/htdocs/cgi-bin/system/modules/Settings.pm b/htdocs/cgi-bin/system/modules/Settings.pm index 95bb874..bedb1ae 100644 --- a/htdocs/cgi-bin/system/modules/Settings.pm +++ b/htdocs/cgi-bin/system/modules/Settings.pm @@ -52,7 +52,7 @@ use constant VW_LOG_WITH_EXCLUDES => 'VW_LOG_WITH_EXCLUDES'; 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'; @@ -98,85 +98,97 @@ our $DEBUG = 1; 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 =~ /<) { + 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;'); @@ -368,7 +380,7 @@ return qq( 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; @@ -441,7 +453,7 @@ sub getConfiguration { &setTimezone; } catch { - SettingsException->throw(error=>$@, show_trace=>$DEBUG); + SettingsException->throw(error=>"DSN:$DSN &getConfiguration.ERR->[$@]", show_trace=>$DEBUG); }; } -- 2.34.1