# 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 = '<table class="tbl" width="'.$PRC_WIDTH.'%">
<tr class="r0"><td colspan="2"><b>* DATE DIFFERENCES *</b></td></tr>';
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] ) {
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 .= '<tr class="r1"><td>'. $dt->ymd . '</td>
</td><td style="text-align:left;">'.$rlog."</td></tr>".
$tbl .= '<tr class="r0"><td colspan="2">'.$dif. '</td> </tr>';
}
$tbl .= '</table>';
+ printHeader("Date Difference Report");
+ print '<a name="top"></a><center><div>'.$tbl.'</div><br><div><a href="main.cgi">Back to Main Log</a></div></center>';
+ print $cgi->end_html();
-print '<a name="top"></a><center><div>'.$tbl.'</div><br><div><a href="main.cgi">Back to Main Log</a></div></center>';
}
-
sub dateDiff {
my($d1,$d2,$ff,$sw)=@_;
if($d1->epoch()>$d2->epoch()){
return "<b>".$d->ymd()."</b> ".$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 "<p>Error->$_</p>";
- $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("<font color=red><b>ERROR</b>$!</font> " . $@);
-}
-}
-
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'},
{-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() );
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";
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;
print $out if(length $out>1);
}
exit;
+ }else{
+ LifeLogException->throw(error => "Invalid Operation \$opr => $opr", show_trace=>1)
}
$st->finish();
-}catch{
- print "<font color=red><b>SERVER ERROR</b>-> Method NotConfirmed() Page Build Failed!.</font>:<pre>".$@."</pre>";
+}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 "<p>Error->$_</p>";
+ $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 "<font color=red><h2>".ref($err)." Encountered!</h2><br></font><p>Building $sub Failed! </p><pre><b>Error:</b> ".$err."</pre>";
+print $cgi->end_html()
}
+
use Text::Wrap; $Text::Wrap::columns=80; $Text::Wrap::separator="\n";
sub log2html {
}
print "<center><div>\n$tbl\n</div></center>";
-
- print $cgi->end_html();
-
-}catch{
- print "<font color=red><b>SERVER ERROR</b>-> Method NotConfirmed() Page Build Failed!.</font>:<pre>".$@."</pre>";
+}catch($e){
+ errorPage($e,'ConfirmForDeletionPage')
}
+print $cgi->end_html();
}
sub cam {
my $am = sprintf( "%.2f", shift);
#
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;
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;
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)
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);
}
}
+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;
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');
}
}
}
$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) {
}
}
-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;
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);
# dmp $self;
#
# We need to do it manually:
+ my $meta = $anons{META};
return qq/
release {$RELEASE_VER}
logPath {$LOG_PATH}
transparent {$TRANSPARENCY}
transimage {$TRANSIMAGE}
language {$LANGUAGE}
+currency {$CURR_SYMBOL}
sessionExprs {$SESSN_EXPR}
imgWidthHeight {$IMG_W_H}
pagePrcWidth {$PRC_WIDTH}
dbName {$dbname}
dsn {$DSN}
isProgressDB {$IS_PG_DB}
-sqlPubors {$SQL_PUB}
- /;
+sqlPubors {$SQL_PUB}
+meta {$meta}
+/
}
1;
\ No newline at end of file
lifelog.hopto.org / LifeLog.git / commitdiff