+++ /dev/null
-#!/usr/bin/env perl
-#
-use strict;
-use warnings;
-use experimental qw( switch );
-use Exception::Class ('LifeLogException');
-use Syntax::Keyword::Try;
-use CGI::Tiny;
-no warnings qw(experimental::signatures);
-use feature qw(signatures);
-use utf8;
-#use lib "/home/will/dev_new/LifeLog/htdocs/cgi-bin/system/modules";
-use lib "system/modules";
-use bignum qw/hex/;
-
-use Gzip::Faster;
-
-require CNFParser;
-sub get_data_path($path){
- $path = "data" unless $path; # The default is data dir.
- $path = "../../$path" unless (-e $path); #cgi executing path is not same to this project local one, so we try resolve.
- mkdir $path unless -e $path;
-return $path;
-}
-sub get_config_file_path {
- my $file = 'app_lifelog_settings.cnf';
- $file = "../../$file" unless(-e $file);
-return $file;
-}
-sub setup_with_last_used_theme($config, $path){
- $path = $path.'/current_theme';
- my $themes = $config -> getTree('THEMES');
- our $THEME = '/';
- if(-e $path){
- open my $fh, '<', $path or return $THEME;
- $THEME = <$fh>;chomp($THEME);
- close($fh);
- }
- my $ret = $$themes -> node($THEME);
- return $$themes if(!$ret);
- return $ret;
-}
-
-
-
-#use CGI::Session '-ip_match';
-# use Data::Section::Simple 'get_data_section';
-
-# cgi {
-# my $cgi = $_;
-
-# # from templates/
-# my $tx = Text::Xslate->new(path => ['templates']);
-
-# # or from __DATA__
-# my $tx = Text::Xslate->new(path => [get_data_section]);
-
-# my $foo = $cgi->query_param('foo');
-# $cgi->render(html => $tx->render('index.tx', {foo => $foo}));
-# };
-
-
-use CGI;
-my $cgi = CGI->new();
-
-
- # $cgi->set_error_handler(
- # sub {
- # my ($cgi, $error, $rendered) = @_;
- # chomp $error;
- # $cgi->render(text=>qq(<html><body><font style="color:crimson; font-weight:bold">You have unfortunately hit an cgi-bin::CNFHTMLServiceError</font>
- # <div class='content-debug_output'><pre style="background:transparent">$error</pre><br> </div>
- # </body></html>
- # )
- # );
- # }
- # );
-
-my $page = qq(
-<html><body>
-
- <div class='content-debug_output'>
- <pre style="background:transparent">
- <h1> DEMO!</h1>
- </pre><br> </div>
-</body></html>
-);
- # $cgi-> add_response_header('Expires', '1s');
- # $cgi-> add_response_header('Cache-Control', 'no-cache');
- # $cgi->reset_response_headers();
- # $cgi-> add_response_header('Content-Encoding', 'gzip');
- # $cgi-> add_response_header('Accept-Encoding','Vary');
- # $cgi-> render(text=>gzip($page));
-
-
-print $cgi->header(-expires => "1s", -charset => "UTF-8", -Content_Encoding => 'gzip');
-print gzip($page);
-
- exit 0;
-
-1;
-
-=begin copyright
-Programed by : Will Budic
-EContactHash : 990MWWLWM8C2MI8K (https://github.com/wbudic/EContactHash.md)
-Source : https://github.com/wbudic/LifeLog
-Open Source Code License -> https://github.com/wbudic/PerlCNF/blob/master/ISC_License.md
-=cut copyright
##no critic qw(Subroutines::RequireFinalReturn)
##no critic Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions
-use constant VERSION => '3.1';
+use constant VERSION => '3.2';
+use constant APPSET => 'APP_SETTINGS';
our @files;
our %lists;
our %properties;
return 0 if(not $value);
return ($value =~ /1|true|yes|on|t|da/i)
}
+
###
# Post parsing instructed special item objects. They have lower priority to Order of apperance and from CNFNodes.
##
package InstructedDataItem {
- our $dataItemCounter = int(0);
+ our %counters;
sub new { my ($class, $ele, $ins, $val) = @_;
my $priority = ($val =~ s/$meta_has_priority/""/sexi)?2:3; $val =~ s/$meta_priority/""/sexi;
$priority = $2 if $2;
+ my $dataItemCounter;
+ if(exists $counters{$ele}){
+ $dataItemCounter = $counters{$ele};
+ }else{
+ $dataItemCounter = {aid=>int(0)};
+ $counters{$ele} = $dataItemCounter;
+ }
bless {
ele => $ele,
- aid => $dataItemCounter++,
+ aid => $dataItemCounter->{aid}++,
ins => $ins,
val => $val,
'^' => $priority
if($ref eq 'ARRAY'){
return @{$ret}
}elsif($ref eq 'PropertyValueStyle'){
- return ${$ret->{plugin}} if $ret->{instructor} eq 'APP_SETTINGS';
+ return ${$ret->{plugin}} if $ret->{instructor} eq APPSET;
return $ret;
}
else{
return @{$an} if defined $an;
die "Error: List name '$t' not found!"
}
+sub listProcessed {
+ my $self = shift;
+ my $t=shift;
+ my @arr = @{$lists{$t}};
+ if(@arr){
+ foreach my$i(0..$#arr){
+ my $anon_name = $arr[$i]->{ele} . $arr[$i]->{aid};
+ @arr[$i]= $self->anon($anon_name);
+ }
+ }
+ return @arr
+}
# Adds a list of environment expected list of variables.
# This is optional and ideally to be called before parse.
#private to parser sub.
sub doInstruction { my ($self,$e,$t,$v) = @_;
my $DO_ENABLED = $self->{'DO_ENABLED'}; my $priority = 0;
- $e = $t if not defined $e;
$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.
}
$tree = CNFNode->new({'_'=>$e,'~'=>$v,'^'=>$priority});
$tree->{DEBUG} = 1 if $self->{DEBUG};
- $instructs{$e} = $tree;
+ $instructs{$e} = \$tree;
}elsif($t eq 'TABLE'){ # This all have now be late bound and send via the CNFSQL package. since v.2.6
# It is hardly been used. But in the future this might change.
my $type = "NONE"; if ($v =~ 'AUTOINCREMENT'){$type = "AUTOINCREMENT"}
elsif($t eq 'MACRO'){
$instructs{$e}=$v;
}
- elsif($t eq 'APP_SETTINGS'){
- $self->instructPlugin(InstructedDataItem -> new($e, 'APP_SETTINGS', $v));
+ elsif($t eq 'APPSET'){
+ $self->instructPlugin(InstructedDataItem -> new($e, APPSET, $v));
}
elsif(exists $instructors{$t}){
if(not $instructors{$t}->instruct($e, $v) && $self->{STRICT}){
sub doDataInstruction_{ 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 $isConstant = $v =~ s/$meta_const//se;
my $isHeader = 0;
$v=~ s/^\s*//gm;
foreach my $row(split(/~\s/,$v)){
my $existing = $self->{'__DATA__'}{$e};
if(defined $existing){
- if($isConstant){
- return; #Not allowed META const protected to overwrite.
- }
if($isHeader){$isHeader=0;next}
my @rows = @$existing;
push @rows, [@a] if scalar @a >0;
$self->{'__DATA__'}{$e} = \@rows
}else{
- if($isConstant){
- $isConstant = 0; #These are constant to be made brand new entries.
- }
my @rows; push @rows, [@a];
$self->{'__DATA__'}{$e} = \@rows if scalar @a >0;
}
if($tag =~ m/^<(\w*)\s+(.*?)>*$/gs){ # Original fastest and early format: <<<anon value>>>
my $t = $1;
my $v = $2;
- if(isReservedWord($self,$t)){
+ if(isReservedWord($self, $t)){
+ my $isAppSts = ($t eq APPSET);
my $isVar = ($t eq 'VARIABLE' || $t eq 'VAR');
- if($t eq 'CONST' or $isVar){ #constant multiple properties.
+ if($t eq 'CONST' or $isVar or $isAppSts){ #multiple values property.
+ my %app_sts;
foreach my $line(split '\n', $v) {
my $isMETAConst = $line =~ s/$meta_const//se;
$line =~ s/^\s+|\s+$//; # strip unwanted spaces
- next if $line =~ m/^[\/\#]+/; #skip this line its a comment dud.
$line =~ s/\s*>$//;
- $line =~ m/([\$\w]*)(\s*[=:]\s*)(.*)/g;
+ $line =~ m/([\$\w]*)(\s*=\s*)(.*)/g;
my $name = $1;
- $line = $3;
- $line =~ s/\s*\#.*$//g; #strip any perl comment at end of line.
- $line =~ s/^\s*(['"])(.*)\g{1}$/$2/ if $line;#strip quotes
+ $line = $3; $line =~ s/^\s*(['"])(.*)\g{1}$/$2/ if $line;#strip quotes
if(defined $name){
- if($isVar && not $isMETAConst){
- $anons ->{$name} = $line if $line
+ if($isAppSts){
+ $app_sts{$name} = $line if $line;
+ }elsif($isVar && not $isMETAConst){
+ $anons -> {$name} = $line if $line
}else{
$name =~ s/^\$// if $isMETAConst;
# It is NOT allowed to overwrite a constant, so check an issue warning.
- if(defined $line and not defined $self->{$name}){
+ if(not exists($self->{$name})){
$self->{$name} = $line;
}else{ my
$w = "Skipping and keeping a previously set constance of -> [$name] in ". $self->{CNF_CONTENT}." the new value ";
- $w .= ($line eq $self->{$name})?"matches it":"dosean't match ($.) -> $line."; $self->warn($w)
+ $w .= ($line eq $self->{$name})?"matches it":"dosean't match -> $line."; $self->warn($w)
}
}
}
}
+ if($isAppSts){
+ $properties{CNFParser::APPSET} = \%app_sts
+ }
}else{
- doInstruction($self,undef,$t,$v);
+ doInstruction($self,$v,$t,undef);
}
}else{
$v =~ s/\s*>$//;
$v = substr $tag, length($e)+1;
$v =~ s/>$// if $t ne '<<' && $tag =~ />$/
}else{
- $tag =~ m/([@%\$\.\/\w]+) ([ <>\n|^\\]{1})+ ([^<^>^^\n]+) ([<>]?) (.*)/gmxs;
- $t = $3;
- $v = $5;
+ $tag =~ m/([@%\$\.\/\w]+) ([ <>\n|^\\]{1})+ ([^<^>^^\n]+) ([<>]?) (.*)/gmxs;
+ $t = $3;
+ $v = $5;
}
}else{
#############################################################################
}
if(!$v && !$RESERVED_WORDS{$t}){
- $v= $t;
+ $v = $t; undef $t
}
$v =~ s/\\</</g; $v =~ s/\\>/>/g;# escaped brackets from v.2.8.
- #Do we have an autonumbered instructed list?
- #DATA best instructions are exempted and differently handled by existing to only one uniquely named property.
- #So its name can't be autonumbered.
+ #Do we have an autonumbered list of anons?
+ #Instructions like DATA can't be autonumbered properties.
if ($e =~ /(.*?)\$\$$/){
$e = $1;
- if($t && $t ne 'DATA'){
- my $array = $lists{$e};
- if(!$array){$array=();$lists{$e} = \@{$array};}
- push @{$array}, InstructedDataItem -> new($e, $t, $v);
- next
+ my @array = ();
+ if(exists $lists{$e}){
+ @array = @{$lists{$e}};
+ }
+ if(!$t or $t ne 'DATA'){
+ push @array, InstructedDataItem -> new($e, $t, $v);
+ $lists{$e} = \@array;
+ next;
}
}elsif ($e eq '@'){#collection processing.
my $isArray = $t=~ m/^@/;
$self -> doInclude($_) if $_ && not $_->{prc_last} and not $_->{loaded} and $_->{local} eq $CUR_SCRIPT;
}
}
+ # Do those autonumbering list anons, and for pre instruction processing prepare if have it.
+ if(%lists){
+ foreach my $arr(values %lists){
+ foreach my $item(@$arr){
+ my $e = $item->{ele} . $item ->{aid};
+ doInstruction($self, $e, $item->{ins},$item->{val});
+ }
+ }
+ undef %InstructedDataItem::counters;
+ }
+
### Do the smart instructions and property linking.
if(%instructs && not $IS_IN_INCLUDE_MODE){
my @items;
foreach my $e(keys %instructs){
my $struct = $instructs{$e};
my $type = ref($struct);
- if($type eq 'String'){
+ if ($type eq 'REF'){
+ $struct = $$struct;
+ $type = ref($struct);
+ }
+ if($type eq 'String'){
my $v = $struct;
my @arr = ($v =~ m/(\$\$\$.+?\$\$\$)/gm);
foreach my $find(@arr) {# <- MACRO TAG translate. ->
my $pck = $plugin->{package};
my $prp = $plugin->{property};
my $sub = $plugin->{subroutine};
- if($instructor eq 'APP_SETTINGS'){
+ if($instructor eq APPSET){
$pck = 'ClassicAppSettings' if ! $pck;
## no critic (RequireBarewordIncludes)
require "$pck.pm";
my $fh = File::ReadBackwards->new($logfile) or die $!;
my @buffer; $buffer[@buffer] = $fh->readline() for (1..$tail_cnt);
open (my $fhTemp, ">", "/tmp/$logfile") or die $!;
- foreach my $ln(reverse @buffer){ print $fhTemp $ln if $ln}
- close $fhTemp;
+ print $fhTemp $_ foreach (reverse @buffer);
+ close $fhTemp;
move("/tmp/$logfile",$logfile)
}
}
}
}
### Utility way to obtain CNFNodes from a configuration.
-# Reference to the node is returned access like: my $tree = $cnf.getTree(..); my $attr = $$tree->{attribute};
sub getTree {
my ($self, $name) = @_;
return $NODES{$name} if exists $NODES{$name};
lifelog.hopto.org / LifeLog.git / commitdiff