From 20ffaa042bb99b4fbc1ec447033f9467a6e746c7 Mon Sep 17 00:00:00 2001 From: Will Budic Date: Wed, 3 May 2023 00:07:44 +1000 Subject: [PATCH] fix. config files not properly read for db fix routines. --- htdocs/cgi-bin/data.cgi | 127 ++++++++++++---------- htdocs/cgi-bin/system/modules/Settings.pm | 117 +++++++++----------- 2 files changed, 121 insertions(+), 123 deletions(-) diff --git a/htdocs/cgi-bin/data.cgi b/htdocs/cgi-bin/data.cgi index 42ecb47..e08b249 100755 --- a/htdocs/cgi-bin/data.cgi +++ b/htdocs/cgi-bin/data.cgi @@ -3,60 +3,56 @@ # Programed in vim by: Will Budic # Open Source License -> https://choosealicense.com/licenses/isc/ # -use v5.34; #use diagnostics; +use v5.30; #use diagnostics; use warnings; use strict; no warnings "experimental::smartmatch"; -##no critic qw(Subroutines::RequireFinalReturn) -##no critic qw(Variables::RequireLocalizedPunctuationVars) -use Exception::Class ('LifeLogException'); +use Exception::Class ('LifeLogException'); use Syntax::Keyword::Try; use DateTime::Format::Human::Duration; use Regexp::Common qw /URI/; use Text::CSV; + use lib "system/modules"; require Settings; -my $db = Settings::fetchDBSettings(); -my $cgi = Settings::cgi(); -my $dbname = Settings::dbName(); my $human = DateTime::Format::Human::Duration->new(); +my $db = Settings::fetchDBSettings(); my $PRC_WIDTH = Settings::pagePrcWidth(); my $DEBUG = Settings::debug(); my $today = Settings::today(); my $tbl_rc = 0; my $imgw = 210; my $imgh = 120; -my $opr = $cgi->param("opr"); +my $cgi = Settings::cgi(); +my $opr = $cgi->param("opr"); $opr=0 if !$opr; my $confirmed = $cgi->param('confirmed'); if ($opr == 1){ - DisplayDateDiffs(); + DisplayDateDiffs(); + exit; } if ($opr == 3){ - PrintView(); + PrintView(); } elsif ($confirmed){ - DeletionConfirmed(); + DeletionConfirmed(); }else{ - print $cgi->redirect('main.cgi') if not $cgi->param('chk'); - NotConfirmed(); + print $cgi->redirect('main.cgi') if not $cgi->param('chk'); + ConfirmForDeletionPage(); } $db->disconnect(); sub DisplayDateDiffs { - - printHeader("Date Difference Report"); + my $tbl = ''; my $stm = 'SELECT DATE, LOG FROM VW_LOG WHERE '; - my @ids = $cgi->param('chk'); - - @ids = reverse @ids; - + my @ids = $cgi->param('chk'); + @ids = reverse @ids; foreach (@ids){ $stm .= "PID = " . $_ .""; if( \$_ != \$ids[-1] ) { @@ -72,7 +68,7 @@ sub DisplayDateDiffs { my $rlog = $row[1]; $rlog =~ m/\n/; $dt = DateTime::Format::SQLite->parse_julianday( $rdat ); - $dt->set_time_zone(&Settings::timezone); + $dt -> set_time_zone(&Settings::timezone); $dif = dateDiff($dt_prev, $dt); $tbl .= '". @@ -90,11 +86,12 @@ sub DisplayDateDiffs { $tbl .= ''; } $tbl .= '
* DATE DIFFERENCES *
'. $dt->ymd . ' '.$rlog."
'.$dif. '
'; + printHeader("Date Difference Report"); + print '
'.$tbl.'

Back to Main Log
'; + print $cgi->end_html(); -print '
'.$tbl.'

Back to Main Log
'; } - sub dateDiff { my($d1,$d2,$ff,$sw)=@_; if($d1->epoch()>$d2->epoch()){ @@ -115,33 +112,11 @@ sub boldDate { return "".$d->ymd()." ".$d->hms; } - -sub DeletionConfirmed { -try{ - my $SQLID = 'rowid'; $SQLID = 'ID' if Settings::isProgressDB(); - my $st1 = $db->prepare("DELETE FROM LOG WHERE $SQLID = ?;"); - my $st2 = $db->prepare("DELETE FROM NOTES WHERE LID = ?;"); - #print $cgi->header(-expires=>"+6os"); - foreach my $id ($cgi->param('chk')){ - my $st = Settings::selectRecords($db, 'select RTF from LOG where '.$SQLID.'='.$id); - my @ra = $st->fetchrow_array(); - $st1->execute($id) or die "

Error->$_

"; - $st2->execute($id) if $ra[0]; - } - #2021-08-11 Added just in case next an renumeration. - # Above also checks now, if a log has flagged having an RTF before deleting the note entry. - Settings::renumerate($db); - print $cgi->redirect('main.cgi'); - -}catch{ - print $cgi->p("ERROR$! " . $@); -} -} - sub printHeader { + my $title = shift; -&Settings::setupTheme; print $cgi->header(-expires=>"+6os"); +&Settings::setupTheme; print $cgi->start_html(-title => $title, -BGCOLOR => Settings::theme('colBG'), -script=> [ {-type => 'text/javascript', -src => 'wsrc/jquery.js'}, {-type => 'text/javascript', -src => 'wsrc/jquery-ui.js'}, @@ -151,12 +126,12 @@ print $cgi->start_html(-title => $title, -BGCOLOR => Settings::theme('colBG'), {-type => 'text/css', -src => 'wsrc/jquery-ui.css'}, {-type => 'text/css', -src => 'wsrc/jquery-ui.theme.css'}, {-type => 'text/css', -src => 'wsrc/jquery-ui.theme.css'} - ], - - -onload => "onBodyLoadGeneric()"); + ], + -onload => "onBodyLoadGeneric()" + ) } -sub NotConfirmed { +sub ConfirmForDeletionPage { try{ my $SQLID = 'rowid'; $SQLID = 'ID' if( Settings::isProgressDB() ); @@ -183,8 +158,8 @@ try{ if($opr == 0){ - printHeader('Confirm Deletion'); - print $cgi->pre("###NotConfirmed()->[stm:$stm]\n]opr:$opr]") if($DEBUG); + printHeader('Confirm Deletion'); + print $cgi->pre("###ConfirmForDeletionPage()->[stm:$stm]\n]opr:$opr]") if($DEBUG); my $r_cnt = 0; my $rs = "r1"; @@ -234,7 +209,7 @@ try{ elsif($opr == 2){ my $csv = Text::CSV-> new ( { binary => 1, escape_char => "\\", strict => 1, eol => $/ } ); my @columns = ("ID", "CAT", "DATE", "LOG", "AMOUNT"); - print $cgi->header(-charset=>"UTF-8", -type=>"application/octet-stream", -attachment=>"$dbname"."_sel.csv"); + print $cgi->header(-charset=>"UTF-8", -type=>"application/octet-stream", -attachment=>Settings::dbName()."_sel.csv"); print $csv->print(*STDOUT, \@columns); while (my $row=$st->fetchrow_arrayref()){ # $row[3] =~ s/\\\\n/\n/gs; @@ -242,13 +217,47 @@ try{ print $out if(length $out>1); } exit; + }else{ + LifeLogException->throw(error => "Invalid Operation \$opr => $opr", show_trace=>1) } $st->finish(); -}catch{ - print "SERVER ERROR-> Method NotConfirmed() Page Build Failed!.:
".$@."
"; +}catch($e){ + errorPage($e,'ConfirmForDeletionPage') +} +} + + +sub DeletionConfirmed { + try{ + my $SQLID = 'rowid'; $SQLID = 'ID' if Settings::isProgressDB(); + my $st1 = $db->prepare("DELETE FROM LOG WHERE $SQLID = ?;"); + my $st2 = $db->prepare("DELETE FROM NOTES WHERE LID = ?;"); + #print $cgi->header(-expires=>"+6os"); + foreach my $id ($cgi->param('chk')){ + my $st = Settings::selectRecords($db, 'select RTF from LOG where '.$SQLID.'='.$id); + my @ra = $st->fetchrow_array(); + $st1->execute($id) or die "

Error->$_

"; + $st2->execute($id) if $ra[0]; + } + #2021-08-11 Added just in case next an renumeration. + # Above also checks now, if a log has flagged having an RTF before deleting the note entry. + Settings::renumerate($db); + print $cgi->redirect('main.cgi'); + + }catch($e){ + errorPage ($e, 'DeletionConfirmed'); + } } + +sub errorPage{ +my $err = shift; +my $sub = shift; +printHeader("ERROR"); +print "

".ref($err)." Encountered!


Building $sub Failed! 

Error: ".$err."
"; +print $cgi->end_html() } + use Text::Wrap; $Text::Wrap::columns=80; $Text::Wrap::separator="\n"; sub log2html { @@ -395,13 +404,11 @@ try{ } print "
\n$tbl\n
"; - - print $cgi->end_html(); - -}catch{ - print "SERVER ERROR-> Method NotConfirmed() Page Build Failed!.:
".$@."
"; +}catch($e){ + errorPage($e,'ConfirmForDeletionPage') } +print $cgi->end_html(); } sub cam { my $am = sprintf( "%.2f", shift); diff --git a/htdocs/cgi-bin/system/modules/Settings.pm b/htdocs/cgi-bin/system/modules/Settings.pm index 0eae57b..864a425 100644 --- a/htdocs/cgi-bin/system/modules/Settings.pm +++ b/htdocs/cgi-bin/system/modules/Settings.pm @@ -6,14 +6,13 @@ # package Settings; use v5.30; #use diagnostics; -use CGI::Carp qw(fatalsToBrowser set_message); use Exception::Class ('SettingsException','LifeLogException','SettingsLimitSizeException'); use Syntax::Keyword::Try; use warnings; no warnings 'experimental'; use strict; use CGI; use CGI::Session '-ip_match'; -use CGI::Carp qw ( fatalsToBrowser ); +use CGI::Carp qw(fatalsToBrowser set_message); use DateTime; use DateTime::Format::SQLite; use DateTime::Duration; @@ -77,7 +76,7 @@ our $KEEP_EXCS = 0; our $COMPRESS_ENC = 0; #HTTP Compressed encoding. our $DBI_SOURCE = "DBI:SQLite:"; our $DBI_LVAR_SZ = 1024; -our $CURR_SYMBOL = '$'; +our $CURR_SYMBOL = '$';#'$'; my ($cgi, $sss, $sid, $alias, $pass, $dbname, $pub); our $DSN; @@ -91,9 +90,11 @@ our %tz_map; our $TH_CSS = 'main.css'; our $JS = 'main.js'; our $BGCOL = '#c8fff8'; + + #Set to 1 to get debug help. Switch off with 0. our $DEBUG = 1; -#END OF SETTINGS + ### Private Settings sofar (id -> name : def.value): #200 -> '^REL_RENUM' : this.$RELEASE_VER (Used in login_ctr.cgi) @@ -192,18 +193,22 @@ try { last if($line =~ />$/); $S_ .= $line . "\n"; } - anonsSet('PLUGINS', $S_); + $anons{'PLUGINS'} = $S_; next; - }elsif($line =~ /'<<'.META.'<'/p){ - anonsSet(META, 1) + }else{ + $v = $v = parseAutonom(META,$line); #($line =~ /<<^CONFIG_META<'/p){ + if($v){ + $anons{META} = $v; + last #we can stop reading the config here, rest of it is irrelevant. + } } - last if parseAutonom(META, $line); + } close $fh; if(!$SQL_PUB&&$pub ne 'test'){$alias=undef} } if(!$alias){ - print $cgi->redirect("login_ctr.cgi?CGISESSID=$sid"); + print $cgi->redirect("login_ctr.cgi?CGISESSID=$sid"); exit; } my $ret = connectDB($dbname, $alias, $pass); @@ -217,6 +222,37 @@ try { } } +my @F = ('', '""', 'false', 'off', 'no', 0);# Placed the 0 last, as never will be checked for in toPropertyValue. +my @T = (1, 'true', 'on', 'yes'); +my $reg_autonom = qr/(<<)(.+?)(<(.*)>*|<)(\n*.+\s*)(>{2,3})/mp; + +sub parseAutonom { #Parses autonom tag for its crest value, returns undef if tag not found or wrong for passed line. + my $tag = shift; + my $line = shift; + return if $line =~ /^\s*[\/#]/; #standard start of single line of comment, skip. + if($line =~ /$reg_autonom/g){ + my ($t,$val) = ($2,$4); + $val =~ s/""$//g; #empty is like not set + $val =~ s/^"|"$//g;chop $val if $val =~ s/>$//g; + if($t eq $tag && $val){ + return toPropertyValue( $val ); + } + } + + return; +} + +sub toPropertyValue { + my $prm = shift; + if($prm){ + my $p = lc $prm; + foreach(@T){return 1 if $_ eq $p} + foreach(@F){return 0 if $_ eq $p} + } + return $prm; +} + + sub today { my $ret = setTimezone(); return $ret; @@ -501,8 +537,8 @@ sub setupTheme { when ("Sun") { %theme = (css=>'wsrc/main_sun.css', colBG=>'#FFD700', colSHDW=>'#FFD700') } when ("Moon") { %theme = (css=>'wsrc/main_moon.css', colBG=>'#000000', colSHDW=>'#DCDCDC') } when ("Earth") { %theme = (css=>'wsrc/main_earth.css', colBG=>'#228B22', colSHDW=>'#8FBC8F') } - default{ - %theme = (css=>'wsrc/main.css',colBG=>'#c8fff8',colSHDW=>'#9baec8'); # Standard; + default { # Standard; + %theme = (css=>'wsrc/main.css',colBG=>'#c8fff8',colSHDW=>'#9baec8'); } } } @@ -749,7 +785,7 @@ sub connectDB { $p = $alias if !$p; $a = 1 if !$a; my $db =$u; - if(!$d){$db = 'data_'.$u.'_log.db';$d=$u} + if(!$d){$db = 'data_'.$u.'_log.db';$dbname = $d=$u} else{ $db = 'data_'.$d.'_log.db';$dbname = $d if !$dbname} $DBFILE = $LOG_PATH.$db; if ($IS_PG_DB) { @@ -764,55 +800,7 @@ sub connectDB { } } -my @F = ('', '""', 'false', 'off', 'no', 0);# Placed the 0 last, as never will be checked for in toPropertyValue. -my @T = (1, 'true', 'on', 'yes'); -# my $reg_autonom = qr/(<<)(.+?)(<)(.*[>]+)*(\n*.+\s*)(>{2,})/mp; -# sub parseAutonom { #Parses autonom tag for its crest value, returns undef if tag not found or wrong for passed line. -# my $tag = shift; -# my $line = shift; -# return if $line =~ /^\s*[\/#]/; #standard start of single line of comment, skip. -# if($line =~ /$reg_autonom/g){ -# #my ($t,$val,$desc) = ($2,$4,$5); -# my ($t,$val) = ($2,$4); -# # if ($ins =~ />$/){ -# # chop $ins; $val=$ins -# # }else{$val=$ins} -# #die "TESTING {\n$t=$ins \n[$val]\n\n}" if $t =~ /^\^\D*/; -# $val =~ s/""$//g; #empty is like not set -# $val =~ s/^"|"$//g; -# if($t eq $tag&&$val){ -# return toPropertyValue( $val ); -# } -# } -# return; -# } -#my $reg_autonom = qr/(<<)(.+?)(<)(\n*.+\s*)(>{3,})/mp; -my $reg_autonom = qr/(<<)(.+?)(<(.*)>*|<)(\n*.+\s*)(>{2,3})/mp; -sub parseAutonom { #Parses autonom tag for its crest value, returns undef if tag not found or wrong for passed line. - my $tag = shift; - my $line = shift; - return if $line =~ /^\s*[\/#]/; #standard start of single line of comment, skip. - if($line =~ /$reg_autonom/g){ - my ($t,$val) = ($2,$4); - $val =~ s/""$//g; #empty is like not set - $val =~ s/^"|"$//g;chop $val if $val =~ s/>$//g; - if($t eq $tag&&$val){ - return toPropertyValue( $val ); - } - } - - return; -} -sub toPropertyValue { - my $prm = shift; - if($prm){ - my $p = lc $prm; - foreach(@T){return 1 if $_ eq $p;} - foreach(@F){return 0 if $_ eq $p;} - } - return $prm; -} use Crypt::Blowfish; use Crypt::CBC; @@ -841,7 +829,7 @@ sub loadLastUsedTheme { sub saveReserveAnons { my $meta = $anons{META}; #since v.2.3 my @dr = split(':', dbSrc()); - LifeLogException->throw(error=>"Meta anon property ^CONFIG_META not found!\n". + LifeLogException->throw(error=>"Meta anon property ".META." not found!\n". "You possibly have an old main.cnf file there.", show_trace=>1) if not $meta; try{ my $db = connectDBWithAutocommit(0); @@ -901,6 +889,7 @@ sub dumpVars { # dmp $self; # # We need to do it manually: + my $meta = $anons{META}; return qq/ release {$RELEASE_VER} logPath {$LOG_PATH} @@ -909,6 +898,7 @@ timezone {$TIME_ZONE} transparent {$TRANSPARENCY} transimage {$TRANSIMAGE} language {$LANGUAGE} +currency {$CURR_SYMBOL} sessionExprs {$SESSN_EXPR} imgWidthHeight {$IMG_W_H} pagePrcWidth {$PRC_WIDTH} @@ -934,8 +924,9 @@ dbFile {$DBFILE} dbName {$dbname} dsn {$DSN} isProgressDB {$IS_PG_DB} -sqlPubors {$SQL_PUB} - /; +sqlPubors {$SQL_PUB} +meta {$meta} +/ } 1; \ No newline at end of file -- 2.34.1