##
use CGI::Carp qw(fatalsToBrowser set_message);
-##
-# This is a entry point script (main).
-##
-use lib::relative "system/modules";
+use lib "/home/will/dev/LifeLog/htdocs/cgi-bin/system/modules";
+#use lib::relative "system/modules";
require CNFParser;
require CNFNode;
our $GLOB_HTML_SERVE = "'{}/*.cgi' '{}/*.htm' '{}/*.html' '{}/*.md' '{}/*.txt'";
our $script_path = $0; $script_path =~ s/\w+.cgi$//;
-use constant LOG_Settings =>q(
+use constant LOG_Settings => q(
<<@<%LOG>
file = web_server.log
# Should it mirror to console too?
console = 0
# Disable/enable output to file at all?
- enabled = 0
+ enabled = 1
# Tail size cut, set to 0 if no tail cutting is desired.
- tail = 1000
+ tail = 60
>>
);
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>
+ </body></html>
)
);
}
);
- exit CNFHTMLService($cgi);
-};
+ # my $p = $cgi->_body_params->{keyed};
+ # $p->{'service'} = ['contacts'];
+ # $p->{'action'} = ['form'];
+
+ ##
+ # This is a entry point script (main).
+ ##
+ exit CNFHTMLService($cgi);
+};
-sub CNFHTMLService {
- my ($cgi,$ptr) = (shift, undef);
- my $cnf = CNFParser -> new (undef,{ DO_ENABLED => 1, HAS_EXTENSIONS=>1, ANONS_ARE_PUBLIC => 1, CGI=>$cgi });
- $cnf->parse(undef,_getServiceScript($cgi));
- $ptr = $cnf->data();
+sub CNFHTMLService($cgi) {
+ my $cnf = CNFParser -> new (undef,{ DO_ENABLED => 1, HAS_EXTENSIONS=>1, ANONS_ARE_PUBLIC => 1, CGI=>$cgi });
+ $cnf -> parse(undef,_getServiceScript($cgi));
+ my $ptr = $cnf->data();
$ptr = $ptr->{'PAGE'};
#say $$ptr if $ptr;
$cgi -> render(text=>$$ptr);
if($service eq 'feeds'){
return _CNF_Script_For_Feeds();
}
+ elsif($service eq 'contacts'){
+ return _CNF_Script_For_Contacts();
+ }
}
+sub _CNF_Script_For_Contacts {
+LOG_Settings . <<__CNF_IS_COOL__;
+<<<INCLUDE htdocs/cgi-bin/contact.cnf>>>
+<<PROVIDE_CONTACT_FORM<PLUGIN>
+
+ package : ContactsPlugin
+ subroutine : process
+ // The property holding the responce for the service.
+ property : ECHASH_CONTACT_RESPONSE
+ // The following maps in the CNF script the table and data properties for transfer/synch to the store.
+ // This shows how CNF can get complicated but also convenient to bind things in its scripts.
+ table : ECHASH_HOLDERS
+ data : CONTACTS_FORM_DATA
+
+>>
+__CNF_IS_COOL__
+}
+
+
sub _CNF_Script_For_Feeds {
LOG_Settings . <<__CNF_IS_COOL__;
<<PROCESS_RSS_FEEDS<PLUGIN>
else {
print
qq(<div id="menu_page" title="To close this menu click on its heart, and wait.">
-<div class="hdr" style="marging=0;padding:0px;">
+<div class="hdr">
<a id="to_top" href="#top" title="Go to top of page."><span class="ui-icon ui-icon-arrowthick-1-n" style="float:none;"></span></a>
Config
<a id="to_bottom" href="#bottom" title="Go to bottom of page."><span class="ui-icon ui-icon-arrowthick-1-s" style="float:none;"></span></a>
--- /dev/null
+!CNF3.0
+
+<<@<%WEB_SERVICE_SETTINGS>
+ $LOG_PATH = ../../dbLifeLog/
+ user =admin
+ pass = admin
+ dbi_source = DBI:SQLite:
+ dbi_store= contacts.db
+>>
+
+<< CONTACTS <TABLE>
+ ID INTEGER NOT NULL UNIQUE,
+ ID_FOR INTEGER NOT NULL UNIQUE,
+ Date TEXT NOT NULL,
+ FullName TEXT NOT NULL,
+ Message TEXT NOT NULL,
+ Status INTEGER,
+ PRIMARY KEY("ID" AUTOINCREMENT)
+>>
+<< ECHASH_HOLDERS <TABLE>
+ ID INTEGER NOT NULL UNIQUE,
+ Alias INTEGER NOT NULL UNIQUE,
+ ECHSH CHARACTER(16) NOT NULL,
+ Name varchar(64),
+ Email TEXT NOT NULL,
+ Details TEXT, PRIMARY KEY("ID" AUTOINCREMENT)
+>>
+
+<<CONTACTS_FORM_DATA<DATA>
+ID`Alias`ECHSH`Name`Image`Email`Details~
+#`webadmin`990MWWLWM8C2MI8K`Will Budic`images/webadmin.png`webadmin@fake.demo-email.com`Administrive Technical Contact.`~
+#`admin`990MWWLWM8C2MI8K`Will Budic`images/webadmin.png`webadmin@fake.demo-email.com`Engeenering site Owner Contact`~
+#`secretary`2435GG2G87HJLKLA`Rachel Zegler`images/zagler.png`zaglerr@fake.demo-email.com`Marketing Officer`~
+>>
+
+<<1>>
+
--- /dev/null
+# Electronic Contact Hash Message Specifications
+
+ ECMessage is an alternative to E-Mail postboxes, utilizing a webservice to provide
+ fast and secure one way contact messages for a website. To the website owner ore admin.
+
+ With this system in place, website scanners or email ants
+ have no way of accessing emails for illegal purposes.
+
+
+## ECHMessage Provides
+
+ * No Email server/client requirements.
+ * Secure service to service channel, if required.
+ * Spam prevention mechanism and message size limitation.
+ * ECHMessage to real email proxy, if setup.
+ * One Message store for multiple aliases, for easier management.
+ * Cross internetwork messaging closed away from the cloud.
+ * Strict private and public info store and presentation.
+ * private is email, real, name and address.
+ * public is alias and the hash.
+ * Hash is not global or domain centralized at all.
+
<<@<%WEBAPP_SETTINGS>
$LOG_PATH = ../../dbLifeLog/
- //We are reading only the css property, old way is the following hash, preserved as reminder.
+ //TODO We are reading only the css property, old way is the following hash, preserved as reminder.
$THEME = css => wsrc/main.css, colBG => #c8fff8, colSHDW => #9baec8
>>
margin:5px;
background: rgba(0, 223, 246, 0.13);
}
-
+ .textual {
+ width: 40%;
+ }
+ .textual p::first-letter {
+ color: blueviolet;
+ initial-letter: 3 2;
+ padding-right: 5pt;
+ }
#content ul {
padding-left: 20px;
}
<a class="ui-button ui-corner-all ui-widget" href="index.cgi">Index</a><hr>
<a class="ui-button ui-corner-all ui-widget" href="main.cgi">Life Log</a><hr>
<a class="ui-button ui-corner-all ui-widget" onclick="return fetchFeeds()">RSS Feeds</a>
-
>#>
>div>
<div<
<a class="ui-button ui-corner-all ui-widget" href="index.cgi">Index</a><hr>
<a class="a_" onclick="return demoLogin()">Demo</a><hr>
<a class="a_" onclick="return fetchFeeds()">Feeds</a><hr>
+ <a class="a_" onclick="return contactForm()">Contact</a><hr>
</div>
<div class="rz login">
$frm
}
sub _toCNFDate ($formated, $timezone) {
my $dt = DateTime::Format::DateParse->parse_datetime($formated, $timezone);
+ die "Unable to parse date:" if not $dt;
return new('CNFDateTime',{epoch => $dt->epoch, datetime=>$dt, TZ=>$timezone});
}
sub _listAvailableCountryCodes(){
+###
# SQL Processing part for the Configuration Network File Format.
-# Programed by : Will Budic
-# Source Origin : https://github.com/wbudic/PerlCNF.git
-# Open Source License -> https://choosealicense.com/licenses/isc/
-#
+###
package CNFJSON;
use strict;use warnings;#use warnings::unused;
return $ret;
}
-1;
\ No newline at end of file
+1;
+
+=begin copyright
+Programed by : Will Budic
+EContactHash : 990MWWLWM8C2MI8K (https://github.com/wbudic/EContactHash.md)
+Source : https://github.com/wbudic/PerlCNF.git
+Documentation : Specifications_For_CNF_ReadMe.md
+ This source file is copied and usually placed in a local directory, outside of its repository project.
+ So it could not be the actual or current version, can vary or has been modiefied for what ever purpose in another project.
+ Please leave source of origin in this file for future references.
+Open Source Code License -> https://github.com/wbudic/PerlCNF/blob/master/ISC_License.md
+=cut copyright
\ No newline at end of file
use warnings;
###
-# TREE instuction meta.
-use constant HAS_PRIORITY => "HAS_PROCESSING_PRIORITY"; # Schedule to process before the rest in synchronous line of instructions.
-
-#
-###
-# DO instruction meta.
-#
-use constant ON_DEMAND => "ON_DEMAND"; #Postpone to evaluate on demand.
-use constant SHELL => "SHELL"; #Execute via system shell.
-
-#
-
-###
-# Returns the regular expresion for any of this meta constances.
+# Returns the regular expresion for any of the meta constances.
##
sub _meta {
my $constance = shift;
}
$constance;
}
+#
+
###
# Priority order no. for instructions.
use constant PRIORITY => qr/(\s*\_+PRIORITY\_(\d+)\_+\s*)/o;
-###
-# Tree instruction has been scripted in collapsed nodes shorthand format.
-# Shortife is parsed faster and with less recursion, but can be prone to script errors,
-# resulting in unintended placings.
-use constant IN_SHORTIFE => qr/(\s*\_+IN_SHORTIFE\_+\s*)/o;
-sub import {
+sub import {
my $caller = caller; no strict "refs";
{
- *{"${caller}::meta"} = \&_meta;
- *{"${caller}::meta_has_priority"} = sub {return _meta(HAS_PRIORITY)};
+
+ # TREE instuction meta.
+ *{"${caller}::meta_has_priority"} = sub {return _meta("HAS_PROCESSING_PRIORITY")};
+ # Schedule to process before the rest in synchronous line of instructions.
*{"${caller}::meta_priority"} = \&PRIORITY;
- *{"${caller}::meta_on_demand"} = sub {return _meta(ON_DEMAND)};
- *{"${caller}::meta_node_in_shortife"} =\&IN_SHORTIFE;
- *{"${caller}::SHELL"} = \&SHELL;
+ #Postpone to evaluate on demand.
+ *{"${caller}::meta_on_demand"} = sub {return _meta("ON_DEMAND")};
+ # Process or load last (includes0.
+ *{"${caller}::meta_process_last"} = sub {return _meta("PROCESS_LAST")};
+ *{"${caller}::meta_const"} = sub {return _meta("CONST")};
+ ###
+ # Tree instruction has been scripted in collapsed nodes shorthand format.
+ # Shortife is parsed faster and with less recursion, but can be prone to script errors,
+ # resulting in unintended placings.
+ *{"${caller}::meta_node_in_shortife"} = sub {return _meta("IN_SHORTIFE")};
+ # Execute via system shell.
+ *{"${caller}::SHELL"} = sub {return _meta("SHELL")};
+ # Returns the regular expresion for any of the meta constances.
+ *{"${caller}::meta"} = \&_meta;
}
- return 1;
+ return 1;
+}
+###
+# CNF DATA instruction headers can contain extra expected data type meta info.
+# This will strip them out and build the best expected SQL create table body, based on this meta.
+# I know, this is crazy stuff, skips having to have to use the TABLE instruction in most cases.
+###
+sub _metaTranslateDataHeader {
+ my $isPostgreSQL = shift;
+ my @array = @_;
+ my ($idType,$body,$primary)=('NONE');
+ my ($INT,$BOOL,$TEXT,$DATE,$ID, $CNFID, $INDEX) = (
+ _meta('INT'),_meta('BOOL'),_meta('TEXT'),_meta('DATE'),
+ _meta('ID'),_meta('CNF_ID'),_meta('CNF_INDEX')
+ );
+ for my $i (0..$#array){
+ my $hdr = $array[$i];
+ if($hdr eq 'ID'){
+ if($isPostgreSQL){
+ $body .= "\"$hdr\" INT UNIQUE PRIMARY KEY GENERATED ALWAYS AS IDENTITY,\n";
+ #$primary = "PRIMARY KEY(ID)"
+ }else{
+ $body .= "\"$hdr\" INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,\n";
+ }
+ # DB provited sequence, you better don't set this when inserting a record.
+ $idType = 'AUTOINCREMENT'
+ }elsif($hdr =~ s/$CNFID/""/ei){
+ #This is where CNF provides the ID uinque int value (which doesn't have to be autonumbered i.e. '#', but must be unique).
+ $body .= "\"$hdr\" INTEGER NOT NULL PRIMARY KEY CHECK (\"$hdr\">0),\n";
+ $idType = 'CNF_INDEX'
+ }elsif($hdr =~ s/$ID/""/ei){
+ #This is ID prefix to some other data id stored in this table, usually one to one/many relationship.
+ $body .= "\"$hdr\" INTEGER CHECK (\"$hdr\">0),\n";
+ }elsif($hdr =~ s/$INDEX/""/ei){
+ # This is where CNF instructs to make a indexed lookup type field,
+ # for inside database fast selecting, hashing, caching and other queries.
+ $body .= "\"$hdr\" varchar(64) NOT NULL PRIMARY KEY,\n";
+ }elsif($hdr =~ s/$INT/""/ei){
+ $body .= "\"$hdr\" INTEGER NOT NULL,\n";
+ }elsif($hdr =~ s/$BOOL/''/ei){
+ if($isPostgreSQL){
+ $body .= "\"$hdr\" BOOLEAN NOT NULL,\n";
+ }else{
+ $body .= "\"$hdr\" BOOLEAN NOT NULL CHECK (\"$hdr\" IN (0, 1)),\n";
+ }
+ }elsif($hdr =~ s/$TEXT/""/ei){
+ $body .= "\"$hdr\" TEXT NOT NULL CHECK (length(\"$hdr\")<=2024),\n";
+ }elsif($hdr =~ s/$DATE/""/ei){
+ $body .= "\"$hdr\" TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP,\n";
+ }else{
+ $body .= "\"$hdr\" TEXT NOT NULL,\n";
+ }
+ $array[$i] = $hdr;
+ }
+ if($primary){
+ $body .= $primary;
+ }else{
+ $body =~ s/,$//
+ }
+return [\@array,\$body,$idType];
}
-
1;
\ No newline at end of file
use Syntax::Keyword::Try;
use Hash::Util qw(lock_hash unlock_hash);
use File::ReadBackwards;
+use File::Copy;
require CNFMeta; CNFMeta::import();
require CNFNode;
our %lists;
our %properties;
our %instructors;
+our $SQL;
###
# Package fields are always global in perl!
###
our %ANONS;
#private -> Instance fields:
- my $anons;
- my %includes;
+ my $anons;
+ my @includes; my $CUR_SCRIPT;
my %instructs;
+ my $IS_IN_INCLUDE_MODE;
+ my $LOG_TRIM_SUB;
###
# CNF Instruction tag covered reserved words.
# You can't use any of these as your own possible instruction implementation, unless in lower case.
$self->{STRICT} = 1 if not exists $self->{STRICT}; #make strict by default if missing.
$self->{ENABLE_WARNINGS} = 1 if not exists $self->{ENABLE_WARNINGS};
$self->{HAS_EXTENSIONS} = 0 if not exists $self->{HAS_EXTENSIONS};
- $self->{RUN_PROCESSORS} = 1 if not exists $self->{RUN_PROCESSORS}; #Bby default enabled, disable during script dev.
+ $self->{RUN_PROCESSORS} = 1 if not exists $self->{RUN_PROCESSORS}; #By default enabled, disable during script dev.
+ # Autoload the data type properties placed in a separate file, from a FILE instruction.
+ $self->{AUTOLOAD_DATA_FILES} =1 if not exists $self->{AUTOLOAD_DATA_FILES};
$self->{CNF_VERSION} = VERSION;
$self->{__DATA__} = {};
- bless $self, $class; $self->parse($path, undef, $del_keys) if($path);
+ undef $SQL;
+ bless $self, $class; $self -> parse($path, undef, $del_keys) if($path);
return $self;
}
#
our $meta_has_priority = meta_has_priority();
our $meta_priority = meta_priority();
our $meta_on_demand = meta_on_demand();
+our $meta_process_last = meta_process_last();
+our $meta_const = meta_const();
+
+
###
# The metaverse is that further this can be expanded,
# to provide further dynamic meta processing of the property value of an anon.
sub _isTrue{
my $value = shift;
return 0 if(not $value);
- return ($value =~ /1|true|yes|on/i)
+ 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.
}
}
$ret = $args->process($n,$ret);
-
}elsif($ref eq 'HASHREF'){
foreach my $key(keys %$args){
if($ret =~ m/\$\$\$$key\$\$\$/g){
# Returns undef if it doesn't exist, and exception if constance required is set;
sub const { my ($self,$c)=@_;
return $self->{$c} if exists $self->{$c};
- CNFParserException->throw("Required constants variable ' $c ' not defined in config!") if $CONSTREQ;
+ if ($CONSTREQ){CNFParserException->throw("Required constants variable ' $c ' not defined in config!")}
+ # Let's try to resolve. As old convention makes constances have a '$' prefix all upprercase.
+ $c = '$'.$c;
+ return $self->{$c} if exists $self->{$c};
return;
}
###
# Collection now returns the contained type dereferenced and is concidered a property.
# Make sure you use the appropriate Perl type on the receiving end.
-# Note, if properties contain any scalar key entry, it sure hasn't been set by this parser.
+# Note, if properties contain any scalar key row, it sure hasn't been set by this parser.
#
sub property { my($self, $name) = @_;
if(exists($properties{$name})){
#private to parser sub.
sub doInstruction { my ($self,$e,$t,$v) = @_;
-
my $DO_ENABLED = $self->{'DO_ENABLED'}; my $priority = 0;
$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.
if (not $self->{$e}){
$anons->{$e} = $v;
}
elsif($t eq 'DATA'){
- $v=~ s/^\n//;
- foreach(split /~\n/,$v){
- my @a;
- $_ =~ 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.
- $d =~ s/~$//; #strip dangling ~ if there was no \n
- $t = substr $d, 0, 1;
- if($t eq '$'){
- $v = $d; #capture specked value.
- $d =~ s/\$$|\s*$//g; #trim any space and system or constant '$' end marker.
- if($v=~m/\$$/){
- $v = $self->{$d}; $v="" if not $v;
- }
- else{
- $v = $d;
- }
- push @a, $v;
- }
- else{
- if($t =~ /^\#(.*)/) {#First is usually ID a number and also '#' signifies number.
- $d = $1;#substr $d, 1;
- $d=0 if !$d; #default to 0 if not specified.
- push @a, $d
- }
- else{
- push @a, $d;
- }
- }
- }
-
- my $existing = $self->{'__DATA__'}{$e};
- if(defined $existing){
- my @rows = @$existing;
- push @rows, [@a] if scalar @a >0;
- $self->{'__DATA__'}{$e} = \@rows
- }else{
- my @rows; push @rows, [@a];
- $self->{'__DATA__'}{$e} = \@rows if scalar @a >0;
- }
- }
-
+ $self->doDataInstruction_($e,$v)
}elsif($t eq 'DATE'){
if($v && $v !~ /now|today/i){
$v =~ s/^\s//;
$v = CNFDateTime::_toCNFDate($v,$self->{'TZ'});
}else{
- $v = CNFDateTime->new(TZ=>$self->{'TZ'});
+ $v = CNFDateTime->new({TZ=>$self->{'TZ'}});
}
$anons->{$e} = $v;
}elsif($t eq 'FILE'){#@TODO Test case this
- my ($i,$path,$cnf_file) = (0,"",$self->{CNF_CONTENT});
- $v=~s/\s+//g;
- $path = substr($path, 0, rindex($cnf_file,'/')) .'/'.$v;
- push @files, $path;
- next if !$self->{'$AUTOLOAD_DATA_FILES'};
- open(my $fh, "<:perlio", $path ) or CNFParserException->throw("Can't open $path -> $!");
- read $fh, my $content, -s $fh;
- close $fh;
- my @tags = ($content =~ m/<<(\w*<(.*?).*?>>)/gs);
- foreach my $tag (@tags){
- next if not $tag;
- my @kv = split /</,$tag;
- $e = $kv[0];
- $t = $kv[1];
- $i = index $t, "\n";
- if($i==-1){
- $t = $v = substr $t, 0, (rindex $t, ">>");
- }
- else{
- $v = substr $t, $i+1, (rindex $t, ">>")-($i+1);
- $t = substr $t, 0, $i;
- }
- if($t eq 'DATA'){
- foreach(split /~\n/,$v){
- my @a;
- $_ =~ 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 '$'){
- $v = $d; #capture spected value.
- $d =~ s/\$$|\s*$//g; #trim any space and system or constant '$' end marker.
- if($v=~m/\$$/){
- $v = $self->{$d}; $v="" if not $v;
- }
- else{
- $v = $d;
- }
- push @a, $v;
- }
- else{
- if($t =~ /^\#(.*)/) {#First is usually ID a number and also '#' signifies number.
- $d = $1;#substr $d, 1;
- $d=0 if !$d; #default to 0 if not specified.
- push @a, $d
- }
- else{
- push @a, $d;
- }
- }
- my $existing = $self->{'__DATA__'}{$e};
- if(defined $existing){
- my @rows = @$existing;
- push @rows, [@a] if scalar @a >0;
- $self->{'__DATA__'}{$e} = \@rows
- }else{
- my @rows; push @rows, [@a];
- $self->{'__DATA__'}{$e} = \@rows if scalar @a >0;
- }
- }
- }
- }
- }
+ $self->doLoadDataFile($e,$v);
}elsif($t eq 'INCLUDE'){
- $includes{$e} = {loaded=>0,path=>$e,v=>$v};
+ if (!$v){
+ $v=$e
+ }else{
+ $anons = $v;
+ }
+ my $prc_last = ($v =~ s/($meta_process_last)/""/ei)?1:0;
+ if (includeContains($v)){
+ $self->warn("Skipping adding include $e, path already is registered for inclusion -> $v");
+ return;
+ }
+ $includes[@includes] = {script=>$v,local=>$CUR_SCRIPT,loaded=>0, prc_last=>$prc_last};
}elsif($t eq 'TREE'){
my $tree = 0;
if (!$v){
$v = $e;
$e = 'LAST_DO';
}
- if( $v =~ s/($meta_has_priority)/""/ei){
+ if( $v =~ s/($meta_has_priority)/""/ei ){
$priority = 1;
}
- if( $v =~ s/$meta_priority/""/sexi){
+ if( $v =~ s/$meta_priority/""/sexi ){
$priority = $2;
}
$tree = CNFNode->new({'_'=>$e,'~'=>$v,'^'=>$priority});
$tree->{DEBUG} = 1 if $self->{DEBUG};
$instructs{$e} = $tree;
- }elsif($t eq 'TABLE'){ # This has now be late bound and send to the CNFSQL package. since v.2.6
- SQL()->createTable($e,$v) } # It is hardly been used. But in future this might change.
- elsif($t eq 'INDEX'){ SQL()->createIndex($v)}
+ }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"}
+ $self->SQL()->createTable($e,$v,$type) }
+ elsif($t eq 'INDEX'){ $self->SQL()->createIndex($v)}
elsif($t eq 'VIEW'){ SQL()->createView($e,$v)}
- elsif($t eq 'SQL'){ SQL($e,$v)}
- elsif($t eq 'MIGRATE'){SQL()->migrate($e, $v)
+ elsif($t eq 'SQL'){ $self->SQL($e,$v)}
+ elsif($t eq 'MIGRATE'){$self->SQL()->migrate($e, $v)
}
elsif($t eq 'DO'){
if($DO_ENABLED){
$v = $e;
$e = 'LAST_DO';
}
- if( $v =~ s/($meta_has_priority)/""/ei){
+ if( $v =~ s/($meta_has_priority)/""/ei ){
$priority = 1;
}
- if( $v =~ s/($meta_priority)/""/sexi){
+ if( $v =~ s/($meta_priority)/""/sexi ){
$priority = $2;
}
- if($v=~ s/($meta_on_demand)/""/ei){
+ if( $v=~ s/($meta_on_demand)/""/ei ){
$anons->{$e} = CNFNode -> new({'_'=>$e,'&'=>$v,'^'=>$priority});
return;
}
}
}
}
+sub doLoadDataFile { my ($self,$e,$v)=@_;
+ my ($path,$cnf_file) = ("",$self->{CNF_CONTENT});
+ $v=~s/\s+//g;
+ if(! -e $v){
+ $path = substr($path, 0, rindex($cnf_file,'/')) .'/'.$v;
+ }
+ foreach(@files){
+ return if $_ eq $path
+ }
+ return if not _isTrue($self->{AUTOLOAD_DATA_FILES});
+ #
+ $self->loadDataFile($e,$path)
+}
+sub loadDataFile { my ($self,$e,$path,$v,$i)=@_;
+
+ open(my $fh, "<:perlio", $path ) or CNFParserException->throw("Can't open $path -> $!");
+ read $fh, my $content, -s $fh;
+ close $fh;
+ #
+ push @files, $path;
+ my @tags = ($content =~ m/<<(\w*<(.*?).*?>>)/gs);
+ foreach my $tag (@tags){
+ next if not $tag;
+ my @kv = split /</,$tag;
+ $e = $kv[0];
+ $tag = $kv[1];
+ $i = index $tag, "\n";
+ if($i==-1){
+ $tag = $v = substr $tag, 0, (rindex $tag, ">>");
+ }
+ else{
+ $v = substr $tag, $i+1, (rindex $tag, ">>")-($i+1);
+ $tag = substr $tag, 0, $i;
+ }
+ if($tag eq 'DATA'){
+ $self->doDataInstruction_($e,$v)
+ }
+ }
+}
+#private
+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 $isHeader = 0;
+ $v=~ s/^\s*//gm;
+ foreach my $row(split(/~\s/,$v)){
+ my @a;
+ $row =~ s/\\`/\\f/g;#We escape to form feed the found 'escaped' backtick so can be used as text.
+ my @cols = $row =~ m/([^`]*)`{0,1}/gm;pop @cols;#<-regexp is special must pop last empty element.
+ foreach my $d(@cols){
+ $d =~ s/\\f/`/g; #escape back form feed to backtick.
+ $d =~ s/^\s*|~$//g; #strip dangling ~ if there was no \n
+ $t = substr $d, 0, 1;
+ if($t eq '$'){
+ $v = $d; #capture specked value.
+ $d =~ s/\$$|\s*$//g; #trim any space and system or constant '$' end marker.
+ if($v=~m/\$$/){
+ $v = $self->{$d};
+ }
+ else{
+ $v = $d;
+ }
+ $v="" if not $v;
+ push @a, $v;
+ }
+ else{
+ if($d =~ /^\#(.*)/) {#First is usually ID a number and also '#' signifies number.
+ $d = $1;
+ $d=0 if !$d; #default to 0 if not specified.
+ push @a, $d
+ }
+ else{
+ $d="" if not $d;
+ push @a, $d;
+ }
+ }
+ }
+ if($add_as_SQLTable){
+ my ($INT,$BOOL,$TEXT,$DATE) = (meta('INT'),meta('BOOL'),meta('TEXT'),meta('DATE'));
+ my $ret = CNFMeta::_metaTranslateDataHeader($isPostgreSQL,@a);
+ my @hdr = @$ret;
+ @a = @{$hdr[0]};
+ $self->SQL()->createTable($e,${$hdr[1]},$hdr[2]);
+ $add_as_SQLTable = 0;$isHeader=1;
+ }
+
+ my $existing = $self->{'__DATA__'}{$e};
+ if(defined $existing){
+ if($isHeader){$isHeader=0;next}
+ my @rows = @$existing;
+ push @rows, [@a] if scalar @a >0;
+ $self->{'__DATA__'}{$e} = \@rows
+ }else{
+ my @rows; push @rows, [@a];
+ $self->{'__DATA__'}{$e} = \@rows if scalar @a >0;
+ }
+ }
+}
###
# Parses a CNF file or a text content if specified, for this configuration object.
}else{
$anons = $self->{'__ANONS__'};
}
- #private %includes; for now we keep on possible multiple calls to parse.
- #private instructs on this parse call.
- %instructs = ();
- # We control from here the constances, as we need to unlock them if previous parse was run.
+ # We control from here the constances, as we need to unlock them if a previous parse was run.
unlock_hash(%$self);
if(not $content){
close $fh;
my @stat = stat($cnf_file);
$self->{CNF_STAT} = \@stat;
- $self->{CNF_CONTENT} = $cnf_file;
+ $self->{CNF_CONTENT} = $CUR_SCRIPT = $cnf_file;
}else{
- my $type =Scalar::Util::reftype($content);
+ my $type = Scalar::Util::reftype($content);
if($type && $type eq 'ARRAY'){
$content = join "",@$content;
$self->{CNF_CONTENT} = 'ARRAY';
- }else{$self->{CNF_CONTENT} = 'script'};
+ }else{
+ $CUR_SCRIPT = \$content;
+ $self->{CNF_CONTENT} = 'script'
+ }
}
$content =~ m/^\!(CNF\d+\.\d+)/;
my $CNF_VER = $1; $CNF_VER="Undefined!" if not $CNF_VER;
if(isReservedWord($self,$t)){
my $isVar = ($t eq 'VARIABLE' || $t eq 'VAR');
if($t eq 'CONST' or $isVar){ #constant multiple properties.
- foreach my $line(split '\n', $v) {
- $line =~ s/^\s+|\s+$//; # strip unwanted spaces
- $line =~ s/\s*>$//;
- $line =~ m/([\$\w]*)(\s*=\s*)(.*)/g;
- my $name = $1;
- $line = $3; $line =~ s/^\s*(['"])(.*)\g{1}$/$2/;#strip quotes
- if(defined $name){
- if($isVar){
- $anons ->{$name} = $line if $line
- }else{
- if($line and not $self->{$name}){# Not allowed to overwrite constant.
- $self->{$name} = $line;
- }else{
- warn "Skipping and keeping previously set constance -> [$name] the new value ".
- ($line eq $self->{$name})?"matches it":"dosean't match -> $line."
- }
+ foreach my $line(split '\n', $v) {
+ my $isMETAConst = $line =~ s/$meta_const//se;
+ $line =~ s/^\s+|\s+$//; # strip unwanted spaces
+ $line =~ s/\s*>$//;
+ $line =~ m/([\$\w]*)(\s*=\s*)(.*)/g;
+ my $name = $1;
+ $line = $3; $line =~ s/^\s*(['"])(.*)\g{1}$/$2/ if $line;#strip quotes
+ if(defined $name){
+ if($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($line and not $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)
}
}
- }
+ }
+ }
}else{
- doInstruction($self,$v,$t,undef);
+ doInstruction($self,$v,$t,undef);
}
}else{
$v =~ s/\s*>$//;
# $t = $1;
# $v = $2;
# }
+ my $IsConstant = ($v =~ s/$meta_const/""/sexi);
my @lst = ($isArray?split(/[,\n]/, $v):split('\n', $v)); $_="";
my @props = map {
s/^\s+|\s+$//; # strip unwanted spaces
my $macro = 0;
if(exists($properties{$t})){
if($self->isReservedWord($t)){
- $self->warn("Skipped overwritting reserved property -> $t.");
+ $self->warn("Skipped a try to overwrite a reserved property -> $t.");
next
}else{
%hsh = %{$properties{$t}}
next if (@pair != 2 || $pair[0] =~ m/^[#\\\/]+/m);#skip, it is a comment or not '=' delimited line.
my $name = $pair[0];
my $value = $pair[1]; $value =~ s/^\s*["']|['"]$//g;#strip quotes
+ if($IsConstant && $p =~ m/\$[A-Z]+/){# if meta constant we check $p if signified to transfer into a CNF constance.
+ if(not exists $self->{$name}){
+ $self->{$name} = $value;
+ next;
+ }
+ }
if($macro){
my @arr = ($value =~ m/(\$\$\$.+?\$\$\$)/gm);
foreach my $find(@arr) {
doInstruction($self,$e,$t,$v)
}
}
+ # Do scripted includes first. As these might set properties imported and processed used by the main script.
+ if(@includes){
+ $includes[@includes] = {script=>$CUR_SCRIPT,loaded=>1, prc_last=>0} if not includeContains($CUR_SCRIPT); #<- to prevent circular includes.
+ foreach (@includes){
+ $self -> doInclude($_) if $_ && not $_->{prc_last} and not $_->{loaded} and $_->{local} eq $CUR_SCRIPT;
+ }
+ }
### Do the smart instructions and property linking.
- if(%instructs){
+ if(%instructs && not $IS_IN_INCLUDE_MODE){
my @items;
foreach my $e(keys %instructs){
my $struct = $instructs{$e};
}
undef %instructs;
}
- #Do scripted includes.
- my @inc = sort values %includes;
- $includes{$0} = {loaded=>1, path=>$self->{CNF_CONTENT}}; #<- to prevent circular includes.
- foreach my $file(@inc){
- if(!$file->{loaded} && $file->{path} ne $self->{CNF_CONTENT}){
- if(open(my $fh, "<:perlio", $file->{path} )){
- read $fh, $content, -s $fh;
- close $fh;
- if($content){
- $file->{loaded} = 1;
- $self->parse(undef, $content)
- }else{
- $self->error("Include content is blank for -> ".$file->{path})
- }
- }else{
- CNFParserException->throw("Can't open ".$file->{path}." -> $!") if $self->{STRICT};
- $file->{loaded} = 0;
- $self->error("Script include not available -> ".$file->{path})
- }
- }
+
+ foreach (@includes){
+ $self -> doInclude($_) if $_ && (not $_->{loaded} and $_->{local} eq $CUR_SCRIPT)
}
+ undef @includes if not $IS_IN_INCLUDE_MODE;
+
foreach my $k(@$del_keys){
delete $self->{$k} if exists $self->{$k}
}
my $runProcessors = $self->{RUN_PROCESSORS} ? 1: 0;
- lock_hash(%$self);#Make repository finally immutable.
+ $self = lock_hash(%$self);#Make repository finally immutable.
runPostParseProcessors($self) if $runProcessors;
+ if ($LOG_TRIM_SUB){
+ $LOG_TRIM_SUB->();
+ undef $LOG_TRIM_SUB;
+ }
return $self
}
#
+ sub includeContains{
+ my $path = shift;
+ foreach(@includes){
+ return 1 if $_&&$_->{script} eq $path
+ }
+ return 0
+ }
+###
+# Loads and parses includes local to script.
+###
+sub doInclude { my ($self, $prp_file) = @_;
+ if(!$prp_file->{loaded}){
+ my $file = $prp_file->{script};
+ if(!-e $file){$file =~ m/.*\/(.*$)/; $file = $1}
+ if(open(my $fh, "<:perlio", $file)){
+ read $fh, my $content, -s $fh;
+ close $fh;
+ if($content){
+ my $cur_script = $CUR_SCRIPT;
+ $prp_file->{loaded} = 1;
+ $CUR_SCRIPT = $prp_file->{script};
+ # Perl is not OOP so instructions are gathered into one place, time will tell if this is desirable rather then a curse.
+ # As per file processing of instructions is not encapsulated within a included file, but main includer or startup script.
+ $IS_IN_INCLUDE_MODE = 1;
+ $self->parse(undef, $content);
+ $IS_IN_INCLUDE_MODE = 0;
+ $CUR_SCRIPT = $cur_script;
+ }else{
+ $self->error("Include content is blank for include -> ".$prp_file->{script})
+ }
+ }else{
+ $prp_file->{loaded} = 0;
+ $self->error("Script include not available for include -> ".$prp_file->{script});
+ CNFParserException->throw("Can't open include ".$prp_file->{script}." -> $!") if $self->{STRICT};
+ }
+ }
+}
sub instructPlugin {
my ($self, $struct, $anons) = @_;
$message = "$type $message" if $isWarning;
- if($message =~ /^ERROR/ || $isWarning){
+ if($message =~ /^ERROR/ || ($isWarning && $self->{ENABLE_WARNINGS})){
warn $time . " " .$message;
}
elsif(%log && $log{console}){
open (my $fh, ">>", $logfile) or die $!;
print $fh $time . " - " . $message ."\n";
close $fh;
- if(_isTrue($log{tail}) && $tail_cnt){
- my $fh = File::ReadBackwards->new($logfile) or die $!;
- if($fh->{lines}>$tail_cnt){
- my $pos = do {
- $fh->readline() for 1..$tail_cnt;
- $fh->tell()
- };
- truncate($logfile, $pos) or die $!;
- }
+ if($tail_cnt>0 && !$LOG_TRIM_SUB){
+ $fh = File::ReadBackwards->new($logfile) or die $!;
+ if($fh->{lines}>$tail_cnt){
+ $LOG_TRIM_SUB = sub {
+ 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 $!;
+ print $fhTemp $_ foreach (reverse @buffer);
+ close $fhTemp;
+ move("/tmp/$logfile",$logfile)
+ }
+ }
}
}
}
foreach (keys(%ENV)){print $_,"=", "\'".$ENV{$_}."\'", "\n"}
}
-our $SQL;
sub SQL {
- if(!$SQL){##It is late compiled on demand.
- require CNFSQL; $SQL = CNFSQL->new();
+ if(!$SQL){##It is late compiled package on demand.
+ my $self = shift;
+ my $data = shift;
+ require CNFSQL; $SQL = CNFSQL->new({parser=>$self});
}
$SQL->addStatement(@_) if @_;
return $SQL;
my $self = shift;
if(!$JSON){
require CNFJSON;
- $JSON = CNFJSON-> new({ CNF_VERSION=>$self->{CNF_VERSION},
- CNF_CONTENT=>$self->{CNF_CONTENT},
- DO_ENABLED =>$self->{DO_ENABLED}
+ $JSON = CNFJSON-> new({ CNF_VERSION => $self->{CNF_VERSION},
+ CNF_CONTENT => $self->{CNF_CONTENT},
+ DO_ENABLED => $self->{DO_ENABLED}
});
}
return $JSON;
}
sub END {
+$LOG_TRIM_SUB->() if $LOG_TRIM_SUB;
undef %ANONS;
undef @files;
undef %properties;
--- /dev/null
+###
+# SQL Processing part for the Configuration Network File Format.
+###
+package CNFSQL;
+
+use strict;use warnings;#use warnings::unused;
+use Exception::Class ('CNFSQLException'); use Carp qw(cluck);
+use Syntax::Keyword::Try;
+use Time::HiRes qw(time);
+use DateTime;
+use DBI;
+use Tie::IxHash;
+
+use constant VERSION => '2.0';
+
+our %tables = (); our %tables_id_type = ();
+our %views = ();
+our %mig = ();
+our @sql = ();
+our @statements;
+our %curr_tables = ();
+
+my $isPostgreSQL = 0;
+my $hasRecords = 0;
+my $TZ;
+
+
+sub new {
+ my ($class, $attrs, $self) = @_;
+ $self = \%$attrs;
+ # By convention any tables and views as appearing in the CNF script should in that order also be created.
+ tie %tables, "Tie::IxHash";
+ tie %views, "Tie::IxHash";
+ bless $self, $class;
+}
+
+
+sub isPostgreSQL{shift; return $isPostgreSQL}
+
+##
+# 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.
+#
+# $map - In general is binding of an CNF table to its DATA property, header of the DATA instructed property is self column resolving.
+# If assinged to an array the first element must contain the name,
+# @TODO 20231018 - Specifications page to be provided with examples for this.
+#
+sub initDatabase { my($self, $db, $do_not_auto_synch, $map, $st) = @_;
+#Check and set CNF_CONFIG
+try{
+ $hasRecords = 0;
+ $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(32) 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(128) NOT NULL,
+ DESCRIPTION VCHAR(256)
+ )|;
+ }
+ $db->begin_work();
+ $db->do($stmt);
+ $self->{parser}->log("CNFParser-> Created CNF_CONFIG table.");
+ $st = $db->prepare('INSERT INTO CNF_CONFIG VALUES(?,?,?);');
+ foreach my $key(sort keys %{$self->{parser}}){
+ my ($dsc,$val);
+ $val = $self->{parser}->const($key);
+ if(ref($val) eq ''){
+ my @sp = split '`', $val;
+ if(scalar @sp>1){$val=$sp[0];$dsc=$sp[1];}else{$dsc=""}
+ $st->execute($key,$val,$dsc);
+ }
+ }
+ $db->commit();
+ }else{ unless ($do_not_auto_synch){
+ 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->{parser}}){
+ my ($dsc,$val);
+ $val = $self->{parser}->const($key);
+ if(ref($val) eq ''){
+ $sel->execute($key);
+ my @a = $sel->fetchrow_array();
+ if(@a==0){
+ my @sp = split '`', $val;
+ if(scalar @sp>1){$val=$sp[0];$dsc=$sp[1];}else{$dsc=""}
+ $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};
+ $self->{parser}->log("CNFParser-> SQL: $st\n");
+ try{
+ $db->do($st);
+ $self->{parser}->log("CNFParser-> Created table: $tbl\n");
+ $do_not_auto_synch = 0;
+ }catch{
+ die "Failed to create:\n$st\nError:$@"
+ }
+ }
+ else{
+ next if $do_not_auto_synch;
+ }
+ }
+ foreach my $tbl(keys %tables){
+ next if $do_not_auto_synch;
+ my @table_info;
+ my $tbl_id_type = $tables_id_type{$tbl};
+ if(isPostgreSQL()){
+ $st = lc $tbl; #we lc, silly psql is lower casing meta and case sensitive for internal purposes.
+ $st="select ordinal_position, column_name, data_type from information_schema.columns where table_schema = 'public' and table_name = '$st';";
+ $self->{parser}->log("CNFParser-> $st", "\n");
+ $st = $db->prepare($st);
+ }else{
+ $st = $db->prepare("pragma table_info($tbl)");
+ }
+ $st->execute();
+ while(my @row_info = $st->fetchrow_array()){
+ $row_info[2] =~ /(\w+)/;
+ $table_info[@table_info] = [$row_info[1], uc $1 ]
+ }
+ my $t = $tbl; my ($sel,$ins,@spec,$q,$qinto);
+ $t = %$map{$t} if $map && %$map{$t};
+ if(ref($t) eq 'ARRAY'){
+ @spec = @$t;
+ $t = $spec[0]; shift @spec;
+ foreach(@spec){ $q.="\"$_\" == ? and " }
+ $q =~ s/\sand\s$//;
+ $st="SELECT * FROM $tbl WHERE $q;";
+ $self->{parser}->log("CNFParser-> $st\n");
+ $sel = $db -> prepare($st);
+ }else{
+ my $prime_key = getPrimaryKeyColumnNameWherePart($db, $tbl);
+ $st="SELECT * FROM $tbl WHERE $prime_key";
+ $self->{parser}->log("CNFParser-> $st\n");
+ $sel = $db -> prepare($st);
+ my @r = $self->selectRecords($db,"select count(*) from $tbl;")->fetchrow_array();
+ $hasRecords = 1 if $r[0] > 0
+ }
+
+ $q = $qinto = ""; my $qa = $tbl_id_type eq 'CNF_INDEX'; foreach(@table_info){
+ if($qa || @$_[0] ne 'ID') {
+ $qinto .="\"@$_[0]\",";
+ $q.="?,"
+ }
+ }
+ $qinto =~ s/,$//;
+ $q =~ s/,$//;
+ $ins = $db -> prepare("INSERT INTO $tbl ($qinto)\nVALUES ($q);");
+
+
+ my $data = $self->{parser} -> {'__DATA__'};
+ if($data){
+ my $data_prp = %$data{$t};
+ if(!$data_prp && $self->{data}){
+ $data_prp = %{$self->{data}}{$t};
+ }
+ if($data_prp){
+ my @hdr;
+ my @rows = @$data_prp;
+ my $auto_increment=0;
+ $db->begin_work();
+ for my $row_idx (0 .. $#rows){
+ my @col = @{$rows[$row_idx]};
+ if($row_idx==0){
+ for my $i(0 .. $#col){
+ $hdr[@hdr]={'_'=>$col[$i],'i'=>$i}
+ }
+ }elsif(@col>0){
+ ##
+ #sel tbl section
+ if(@spec){
+ my @trans = ();
+ foreach my $name (@spec){
+ foreach(@hdr){
+ my $hn = $_->{'_'};
+ my $hi = $_->{'i'};
+ if($name =~ m/ID/i){
+ if($col[$hi]){
+ $trans[@trans] = $col[$hi];
+ }else{
+ $trans[@trans] = $row_idx; # The row index is ID as default on autonumbered ID columns.
+ }
+ last
+ }elsif($name =~ m/$hn/i){
+ $trans[@trans] = $col[$hi];
+ last
+ }
+ }
+ }
+ next if @trans && hasEntry($sel, \@trans);
+ }else{
+ next if hasEntry($sel, $row_idx); # ID is assumed autonumbered on by default
+ }
+ ##
+ my @ins = ();
+ foreach(@hdr){
+ my $hn = $_->{'_'};
+ my $hi = $_->{'i'};
+ for my $i(0 .. $#table_info){
+ if ($table_info[$i][0] =~ m/$hn/i){
+ if($table_info[$i][0]=~/ID/i){
+ if($col[$hi]){
+ $ins[$i] = $col[$hi];
+ }else{
+ $ins[$i] = $row_idx; # The row index is ID as default on autonumbered ID columns.
+ }
+ $auto_increment=$i+1 if $tbl_id_type eq 'AUTOINCREMENT';
+ }else{
+ my $v = $col[$hi];
+ if($table_info[$i][1] =~ /TIME/ || $table_info[$i][1] =~ /DATE/){
+ $TZ = exists $self->{parser}->{'TZ'} ? $self->{parser}->{'TZ'} : CNFDateTime::DEFAULT_TIME_ZONE() if !$TZ;
+ if($v && $v !~ /now|today/i){
+ if($self->{STRICT}&&$v!~/^\d\d\d\d-\d\d-\d\d/){
+ $self-> warn("Invalid date format: $v expecting -> YYYY-MM-DD at start as possibility of DD-MM-YYYY or MM-DD-YYYY is ambiguous.")
+ }
+ $v = CNFDateTime::_toCNFDate($v,$TZ) -> toTimestamp()
+ }else{
+ $v = CNFDateTime->new({TZ=>$TZ}) -> toTimestamp()
+ }
+ }elsif($table_info[$i][1] =~ m/^BOOL/){
+ $v = CNFParser::_isTrue($v) ?1:0;
+ }
+ $ins[$i] = $v
+ }
+ last;
+ }
+ }
+ }
+ $self->{parser}->log("CNFParser-> Insert into $tbl -> ". join(',', @ins)."\n");
+ if($auto_increment){
+ $auto_increment--;
+ splice @ins, $auto_increment, 1
+ }
+ $ins->execute(@ins);
+ }
+ }
+ $db->commit()
+ }else{
+ $self->{parser}->log("CNFParser-> No data collection is available for $tbl\n");
+ }
+ }else{
+ $self->{parser}->log("CNFParser-> No data collection scanned for $tbl\n");
+ }
+
+ }
+
+ foreach my $view(keys %views){
+ if(!$curr_tables{$view}){
+ $st = $views{$view};
+ $self->{parser}->log("CNFParser-> SQL: $st\n");
+ $db->do($st);
+ $self->{parser}->log("CNFParser-> Created view: $view\n")
+ }
+ }
+ undef %tables; undef %tables_id_type;
+ undef %views;
+}
+catch{
+ CNFSQLException->throw(error=>$@, show_trace=>1);
+}
+return $self->{parser}-> const('$RELEASE_VER');
+}
+
+sub _connectDB {
+ my ($user, $pass, $source, $store, $path) = @_;
+ if($path && ! -e $path){
+ $path =~ s/^\.\.\/\.\.\///g;
+ }else{
+ $path = ""
+ }
+ my $DSN = $source .'dbname='.$path.$store;
+ try{
+ return DBI->connect($DSN, $user, $pass, {AutoCommit => 1, RaiseError => 1, PrintError => 0, show_trace=>1});
+ }catch{
+ die "<p>Error->$@</p><br><pre>DSN: $DSN</pre>";
+ }
+}
+sub _credentialsToArray{
+ return split '/', shift
+}
+
+sub createTable { my ($self, $name, $body, $idType) = @_;
+ $tables{$name} = "CREATE TABLE $name(\n$body);";
+ $tables_id_type{$name} = $idType;
+}
+sub createView { my ($self, $name, $body) = @_;
+ $views{$name} = "CREATE VIEW $name AS $body;"
+}
+sub createIndex { my ($self, $body) = @_;
+ my $st = "CREATE INDEX $body;";
+ push @sql, $st;
+}
+sub migrate { my ($self, $name, $value) = @_;
+ my @m = $mig{$name};
+ @m = () if(!@m);
+ push @m, $value;
+ $mig{$name} = [@m];
+}
+sub addStatement { my ($self, $name, $value) = @_;
+ $self->{$name}=$value;
+}
+sub getStatement { my ($self, $name) = @_;
+ return $self->{$name} if exists $self->{$name};
+ return;
+}
+sub hasEntry{ my ($sel, $uid) = @_;
+ return 0 if !$hasRecords;
+ if(ref($uid) eq 'ARRAY'){
+ $sel -> execute(@$uid)
+ }else{
+ $uid=~s/^["']|['"]$//g;
+ $sel -> execute($uid)
+ }
+ my @r=$sel->fetchrow_array();
+ return scalar(@r);
+}
+
+sub getPrimaryKeyColumnNameWherePart { my ($db,$tbl) = @_; $tbl = lc $tbl;
+ my $sql = $isPostgreSQL ?
+qq(SELECT a.attname, format_type(a.atttypid, a.atttypmod) AS data_type
+FROM pg_index i
+JOIN pg_attribute a ON a.attrelid = i.indrelid
+ AND a.attnum = ANY(i.indkey)
+WHERE i.indrelid = '$tbl'::regclass
+AND i.indisprimary;) :
+
+qq(PRAGMA table_info($tbl););
+
+
+my $st = $db->prepare($sql); $st->execute();
+my @r = $st->fetchrow_array();
+if(!@r){
+ CNFSQLException->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){
+ CNFSQLException->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{
+ CNFSQLException->throw(error=>"Database error encountered!\n ERROR->$@\n SQL-> $sql DSN:".$db, show_trace=>1);
+ }
+}
+#@deprecated
+sub tableExists { my ($self, $db, $tbl) = @_;
+ try{
+ $db->do("select count(*) from $tbl;");
+ return 1;
+ }catch{}
+ return 0;
+}
+###
+# Buffer loads initiated a file for sql data instructions.
+# TODO 2020-02-13 Under development.
+#
+sub initLoadDataFile {# my($self, $path) = @_;
+return 0;
+}
+###
+# Reads next collection of records into buffer.
+# returns 2 if reset with new load.
+# returns 1 if done reading data tag value, last block.
+# returns 0 if done reading file, same as last block.
+# readNext is accessed in while loop,
+# filling in a block of the value for a given CNF tag value.
+# Calling readNext, will clear the previous block of data.
+# TODO 2020-02-13 Under development.
+#
+sub readNext(){
+return 0;
+}
+
+sub END {
+undef %tables;undef %views;
+}
+
+1;
+
+=begin copyright
+Programed by : Will Budic
+EContactHash : 990MWWLWM8C2MI8K (https://github.com/wbudic/EContactHash.md)
+Source : https://github.com/wbudic/PerlCNF.git
+Documentation : Specifications_For_CNF_ReadMe.md
+ This source file is copied and usually placed in a local directory, outside of its repository project.
+ So it could not be the actual or current version, can vary or has been modiefied for what ever purpose in another project.
+ Please leave source of origin in this file for future references.
+Open Source Code License -> https://github.com/wbudic/PerlCNF/blob/master/ISC_License.md
+=cut copyright
\ No newline at end of file
--- /dev/null
+package ContactsPlugin;
+
+use strict;
+use warnings;
+no warnings qw(experimental::signatures);
+use feature qw(signatures);
+use Syntax::Keyword::Try;
+use Clone qw(clone);
+use DBI;
+
+use constant VERSION => '1.0';
+
+CNFParser::import();
+
+sub new ($class, $plugin){
+ my $settings;
+ if($plugin){
+ $settings = clone $plugin; #clone otherwise will get hijacked with blessings.
+ }
+ return bless $settings, $class
+}
+
+###
+# Process config data to contain expected fields.
+###
+sub process ($self, $parser, $property) {
+ $self->{date} = now();
+ my %S = $parser-> collection('%WEB_SERVICE_SETTINGS');
+ my $SQL = $parser-> SQL();
+ my $db = CNFSQL::_connectDB($S{user},$S{pass},$S{dbi_source},$S{dbi_store},$S{LOG_PATH});
+ # The mighty CNFParser reads the plugin CNF property and sets our plugin, to scripted attribute bindings, for sql table and data.
+ $SQL -> initiDatabase($db,0,{$self->{table}=>$self->{data}});
+ my %hdr = $SQL -> getDataHeaderMap($self->{table});
+ my $cgi = $parser -> {CGI};
+ my $action = $cgi -> param('action');
+ my $buffer;
+
+ if($action eq 'form'){
+ my $st = $SQL -> selectRecords($db,"select * from $self->{table}");
+
+ $buffer = js().css().qq(
+ <p class="styled-message">Please select who you wish to send a contact message from the following table.<p>
+ <table class="styled-table" style="width:fit-content;">
+ <thead>
+ <td>ID</td>
+ <td>Contact</td>
+ <td>ECHASH</td>
+ </thead>
+ <tbody>
+ );
+ while (my @row = $st->fetchrow_array()){
+ my $details = $row[$hdr{Details}]; $details = "" if not $details;#driver returns empty string as undef from table.
+ $buffer .= qq(
+ <tr>
+ <td>$row[$hdr{ID}]</td>
+ <td><a onclick="return contact('$row[$hdr{Alias}]','$row[$hdr{ECHSH}]')">$row[$hdr{Alias}]<a></td>
+ <td><a onclick="return contact('$row[$hdr{Alias}]','$row[$hdr{ECHSH}]')">$row[$hdr{ECHSH}]</a></td>
+ </tr>
+ <tr><td colspan="3">$details</td></tr>
+ )
+ }
+ $buffer .= "</tbody>\n</table>";
+ $buffer .= qq( <div id="div_contact" class="styled-table"
+ style="text-align: left; padding: 15px; visibility:hidden">
+ <form id="frm_contact" action="CNFServices.cgi" method="post">
+ <input type="hidden" name="service" value="contacts"/>
+ <input type="hidden" name="action" value="contact"/>
+ <label for="poster_name">Your Name:</label>
+ <input type="text" id="poster_name" name="poster_name" value="" required><br><br>
+ <label for="poster_email">Your Email:</label>
+ <input type="text" id="poster_email" name="poster_email" value="" required><br><br>
+ <label for="poster_contacts">You are Contacting:</label>
+ <input type="text" id="poster_contacts" name="poster_contacts" value=""
+ style="width:70px;" readonly>
+ <input type="text" name="echsh" value="" readonly/><br><br>
+ <label for="post">Your Message:</label><br><br>
+
+ <textarea name="post" rows="10" autocorrect="on" required></textarea><br><br>
+
+ <input type="submit" value="Submit" class="ui-button">
+ </form>
+ </div>
+ );
+ }
+ $parser->data()->{PAGE} = \$buffer;
+
+ #$parser->data()->{$property} = \@data
+}
+sub js{
+<<JS
+<script>
+
+
+</script>
+JS
+}
+sub css{
+<<CSS
+<style>
+ .styled-table {
+ display: block;
+ border-collapse: collapse;
+ margin: 25px 0;
+ font-size: 0.9em;
+ font-family: sans-serif;
+ box-shadow: 8px 10px 20px rgba(0, 0, 0, 0.572);
+}
+.styled-table thead tr {
+ background-color: #00fbff;
+ color: #121111;
+ text-align: left;
+ font-weight: bold;
+}
+
+.styled-table td{
+ border:1px solid black;padding: 5px;margin: 0;
+ padding: 12px 15px;
+}
+.styled-table a{
+ cursor:pointer;
+}
+.styled-table tbody tr {
+ border-bottom: 1px solid #eff190;
+}
+.styled-table tbody tr:nth-of-type(even) {
+ background-color: #f9b5b5;
+}
+.styled-table tbody tr:last-of-type {
+ border-bottom: 1px solid #000000;
+ border-right: 1px solid #000000;
+}
+.styled-table tbody tr:hover {
+ font-weight: bold;
+ background-color: #98fce8;
+}
+.styled-table textarea{
+ overflow-y: scroll;
+ overflow: scroll;
+ width:98%;
+}
+.styled-message{
+ margin-left: 0;
+ font-weight: bold;
+ text-shadow: 8px 10px 20px rgba(0, 0, 0, 0.572)}
+</style>
+CSS
+}
+
+1;
+
+
+=begin copyright
+Programed by : Will Budic
+EContactHash : 990MWWLWM8C2MI8K (https://github.com/wbudic/EContactHash.md)
+Source : https://github.com/wbudic/PerlCNF.git
+Documentation : Specifications_For_CNF_ReadMe.md
+ This source file is copied and usually placed in a local directory, outside of its repository project.
+ So it could not be the actual or current version, can vary or has been modiefied for what ever purpose in another project.
+ Please leave source of origin in this file for future references.
+Open Source Code License -> https://github.com/wbudic/PerlCNF/blob/master/ISC_License.md
+=cut copyright
\ No newline at end of file
--- /dev/null
+package DataProcessorPlugin;
+
+use strict;
+use warnings;
+
+use feature qw(signatures);
+use Scalar::Util qw(looks_like_number);
+use Clone qw(clone);
+use Date::Manip;
+
+use constant VERSION => '1.0';
+
+sub new ($class, $plugin){
+ my $settings;
+ if($plugin){
+ $settings = clone $plugin; #clone otherwise will get hijacked with blessings.
+ }
+ return bless $settings, $class
+}
+
+###
+# Process config data to contain expected fields and data.
+###
+sub process ($self, $parser, $property) {
+ my @data = $parser->data()->{$property};
+#
+# The sometime unwanted side of perl is that when dereferencing arrays,
+# modification only is visible withing the scope of the block.
+# Following processes and creates new references on modified data.
+# And is the reason why it might look ugly or has some unecessary relooping.
+#
+ for my $did (0 .. $#data){
+ my @entry = @{$data[$did]};
+ my $ID_Spec_Size = 0;
+ my @SPEC;
+ my $mod = 0;
+ foreach (@entry){
+ my @row = @$_;
+ $ID_Spec_Size = scalar @row;
+ for my $i (0..$ID_Spec_Size-1){
+ if($row[$i] =~ /^#/){
+ $SPEC[$i] = 1;
+ }
+ elsif($row[$i] =~ /^@/){
+ $SPEC[$i] = 2;
+ }
+ else{
+ $SPEC[$i] = 3;
+ }
+ }#rof
+ if($row[0]){
+ # Cleanup header label row for the columns, if present.
+ shift @entry;
+ #we are done spec obtained from header just before.
+ last
+ }
+ }
+ my $size = $#entry;
+ my $padding = length($size);
+ for my $eid (0 .. $size){
+ my @row = @{$entry[$eid]};
+ if ($ID_Spec_Size){
+ # If zero it is presumed ID field, corresponding to row number + 1 is our assumed autonumber.
+ if($row[0] == 0){
+ my $times = $padding - length($eid+1);
+ $row[0] = zero_prefix($times,$eid+1);
+ $mod = 1
+ }
+ if(@row!=$ID_Spec_Size){
+ warn "Row data[$eid] doesn't match expect column count: $ID_Spec_Size\n @row";
+ }else{
+ for my $i (1..$ID_Spec_Size-1){
+ if(not matchType($SPEC[$i], $row[$i])){
+ warn "Row in row[$i]='$row[$i]' doesn't match expect data type, contents: @row";
+ }
+ elsif($SPEC[$i]==2){
+ my $dts = $row[$i];
+ my $dt = UnixDate(ParseDateString($dts), "%Y-%m-%d %T");
+ if($dt){ $row[$i] = $dt; $mod = 1 }else{
+ warn "Row in row[$i]='$dts' has imporper date format, contents: @row";
+ }
+ }else{
+ my $v = $row[$i];
+ $v =~ s/^\s+|\s+$//gs;
+ $row[$i] =$v;
+ }
+ }
+ }
+ $entry[$eid]=\@row if $mod; #<-- re-reference as we changed the row. Something hard to understand.
+ }
+ }
+ $data[$did]=\@entry if $mod;
+ }
+ $parser->data()->{$property} = \@data;
+}
+sub zero_prefix ($times, $val) {
+ if($times>0){
+ return '0'x$times.$val;
+ }else{
+ return $val;
+ }
+}
+sub matchType($type, $val, @rows) {
+ if ($type==1 && looks_like_number($val)){return 1}
+ elsif($type==2){
+ if($val=~/\d*\/\d*\/\d*/){return 1}
+ else{
+ return 1;
+ }
+ }
+ elsif($type==3){return 1}
+ return 0;
+}
+
+1;
+
+=begin copyright
+Programed by : Will Budic
+EContactHash : 990MWWLWM8C2MI8K (https://github.com/wbudic/EContactHash.md)
+Source : https://github.com/wbudic/PerlCNF.git
+Documentation : Specifications_For_CNF_ReadMe.md
+ This source file is copied and usually placed in a local directory, outside of its repository project.
+ So it could not be the actual or current version, can vary or has been modiefied for what ever purpose in another project.
+ Please leave source of origin in this file for future references.
+Open Source Code License -> https://github.com/wbudic/PerlCNF/blob/master/ISC_License.md
+=cut copyright
\ No newline at end of file
--- /dev/null
+package DataProcessorWorldCitiesPlugin;
+
+use strict;
+use warnings;
+
+use feature qw(signatures);
+use Scalar::Util qw(looks_like_number);
+
+
+sub new ($class,$plugin){
+ return bless {}, $class
+}
+
+###
+# Process config data to contain expected fields and data.
+###
+sub process ($self, $parser, $property) {
+
+ my @data = $parser->data()->{$property};
+
+ for my $did (0 .. $#data){
+ my @entry = @{$data[$did]};
+ my $Spec_Size = 0;
+ my $mod = 0;
+ # Cleanup header labels row.
+ shift @entry;
+ }
+ $parser->data()->{$property} = \@data;
+}
+
+###
+# Process config data directly from a raw data file containing no Perl CNF tags.
+# This is prefered way if your data is over, let's say 10 000 rows.
+###
+
+sub loadAndProcess ($self, $parser, $property) {
+
+ my @data;
+ local $/ = undef;
+ my $file = $parser->anon($property);
+ open my $fh, '<', $file or die ("$!");
+ foreach(split(/~\n/,<$fh>)){
+ my @a;
+ $_ =~ 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.
+ $d =~ s/~$//; #strip dangling ~ if there was no \n
+ my $t = substr $d, 0, 1;
+ if($t eq '$'){
+ my $v = $d; #capture spected value.
+ $d =~ s/\$$|\s*$//g; #trim any space and system or constant '$' end marker.
+ if($v=~m/\$$/){
+ $v = $self->{$d}; $v="" if not $v;
+ }
+ else{
+ $v = $d;
+ }
+ push @a, $v;
+ }
+ else{
+ if($t =~ /^\#(.*)/) {#First is usually ID a number and also '#' signifies number.
+ $d = $1;#substr $d, 1;
+ $d=0 if !$d; #default to 0 if not specified.
+ push @a, $d
+ }
+ else{
+ push @a, $d;
+ }
+ }
+ }
+ $data[@data]= \@a;
+ }
+ close $fh;
+ $parser->data()->{$property} = \@data;
+}
+
+1;
+
+=begin copyright
+Programed by : Will Budic
+EContactHash : 990MWWLWM8C2MI8K (https://github.com/wbudic/EContactHash.md)
+Source : https://github.com/wbudic/PerlCNF.git
+Documentation : Specifications_For_CNF_ReadMe.md
+ This source file is copied and usually placed in a local directory, outside of its repository project.
+ So it could not be the actual or current version, can vary or has been modiefied for what ever purpose in another project.
+ Please leave source of origin in this file for future references.
+Open Source Code License -> https://github.com/wbudic/PerlCNF/blob/master/ISC_License.md
+=cut copyright
\ No newline at end of file
###
# Process config data to contain expected fields and data.
###
-sub convert ($self, $parser, $property) {
+sub convert ($self, $parser, $property) {
my ($buffer,$title, $link, $body_attrs, $body_on_load, $give_me);
my $cgi = CGI -> new();
- my $cgi_action = $cgi-> param('action');
- my $cgi_doc = $cgi-> param('doc');
+ my $cgi_action = $cgi-> param('action');
+ my $cgi_doc = $cgi-> param('doc');
my $tree = $parser-> anon($property);
- die "Tree property '$property' is not available!" if(!$tree or ref($tree) ne 'CNFNode');
+ die "Tree property '$property' is not available!" if(!$tree or ref($tree) ne 'CNFNode');
+
try{
- #TODO 20231002 Move -> %WEBAPP_SETTINGS into utility.
- my %THEME;
- my %wsettings = $parser -> collection('%WEBAPP_SETTINGS');
- if(%wsettings){
- my $theme = $wsettings{THEME};
- my @els = split(/, /, $theme);
- foreach (@els) {
- my ($key,$val) = split(/\s*=>\s*/, $_);
- $THEME{$key} = $val;
- last if $key eq 'css'
- }
- my $theme_file = $wsettings{LOG_PATH}.'current_theme';
- $theme_file =~ /^\.\.\/\.\.\// if(-e $theme_file);
- if(-e $theme_file){
- open my $fh, '<', $theme_file;
- my $theme = <$fh>;
- close($fh);
- if($theme =~ m/standard/i){
- $THEME{css} = "wsrc/main.css"
- }elsif($theme =~ m/moon/i){
- $THEME{css} = "wsrc/main_moon.css"
- }
- elsif($theme =~ m/sun/i){
- $THEME{css} = "wsrc/main_sun.css"
- }
- elsif($theme =~ m/earth/i){
- $THEME{css} = "wsrc/main_earth.css"
- }
- }
- }
- if (exists $parser->{'HTTP_HEADER'}){
+
+ if (exists $parser->{'HTTP_HEADER'}){
$buffer .= $parser-> {'HTTP_HEADER'};
- }else{
+ }else{
if(exists $parser -> collections()->{'%HTTP_HEADER'}){
my %http_hdr = $parser -> collection('%HTTP_HEADER');
$buffer = $cgi->header(%http_hdr);
}
}
- if ($cgi_action and $cgi_action eq 'load'){
- $buffer .= $cgi->start_html(); my
+
+ if ($cgi_action and $cgi_action eq 'load'){
+ $buffer .= $cgi->start_html(); my
$load = loadDocument($parser, $cgi_doc);
if($load){
- $buffer .= $$load if $load;
+ $buffer .= $$load if $load;
}else{
$buffer .= "Document is empty: $cgi_doc\n"
- }
+ }
}else{
$title = $tree -> {'Title'} if exists $tree->{'Title'};
$link = $tree -> {'HEADER'};
if($link){
if(ref($link) eq 'CNFNode'){
my $arr = $link->find('CSS/@@');
- foreach (@$arr){
- if($THEME{css} && $_->val() =~ /main.css$/){
- push @hhshCSS, {-type => 'text/css', -src => $THEME{css}};
- }else{
- push @hhshCSS, {-type => 'text/css', -src => $_->val()};
- }
+ foreach (@$arr){
+ push @hhshCSS, {-type => 'text/css', -src => $_->val()};
}
$arr = $link->find('JS/@@');
- foreach (@$arr){
- push @hhshJS, {-type => 'text/javascript', -src => $_->val()};
- }
+ foreach (@$arr){
+ push @hhshJS, {-type => 'text/javascript', -src => $_->val()};
+ }
$arr = $link -> find('STYLE');
if(ref($arr) eq 'ARRAY'){
foreach (@$arr){
}
$arr = $link -> find('SCRIPT');
if(ref($arr) eq 'ARRAY'){
- foreach (@$arr){
- my $attributes = _nodeHTMLAtrributes($_);
- $give_me .= "\n<script$attributes>\n".$_ -> val()."\n</script>\n"
+ foreach (@$arr){
+ $give_me .= "\n<script>\n".$_ -> val()."\n</script>\n"
}}else{
- my $attributes = _nodeHTMLAtrributes($arr);
- $give_me .= "\n<script$attributes>\n".$arr -> val()."\n</script>\n";
-
+ $give_me .= "\n<script>\n".$arr -> val()."\n</script>\n"
}
- }
- delete $tree -> {'HEADER'};
- }
+ }
+ delete $tree -> {'HEADER'};
+ }
$buffer .= $cgi->start_html(
-title => $title,
-onload => $body_on_load,
- # -BGCOLOR => $colBG,
+ # -BGCOLOR => $colBG,
-style => \@hhshCSS,
-script => \@hhshJS,
-head=>$give_me,
$body_attrs
);
- foreach my $node($tree->nodes()){
+ foreach my $node($tree->nodes()){
$buffer .= build($parser, $node) if $node;
}
$buffer .= $cgi->end_html();
}
$parser->data()->{$property} = \$buffer;
}catch($e){
- HTMLIndexProcessorPluginException->throw(error=>$e);
+ HTMLIndexProcessorPluginException->throw(error=>$e ,show_trace=>1);
}
}
-
-sub _nodeHTMLAtrributes {
- my $node = shift;
- my $attributes =" ";
- my @attrs = $node -> attributes();
- foreach my $a(@attrs){
- $attributes .= @$a[0] . " = \"" .@$a[1]."\""
- }
- $attributes = "" if $attributes eq " ";
- return $attributes
-}
#
sub loadDocument($parser, $doc) {
my $slurp = do {
- open my $fh, '<:encoding(UTF-8)', $doc or HTMLIndexProcessorPluginException->throw(error=>"Document not avaliable -> \"$doc\" ", show_trace=>1);
+ open my $fh, '<:encoding(UTF-8)', $doc or HTMLIndexProcessorPluginException->throw("Document not avaliable: $doc");
local $/;
- <$fh>;
+ <$fh>;
};
if($doc =~/\.md$/){
- require MarkdownPlugin;
- my @r = @{MarkdownPlugin->new(undef)->parse($slurp)};
+ require MarkdownPlugin;
+ my @r = @{MarkdownPlugin->new()->parse($slurp)};
return $r[0];
}
- return \$slurp
+ return \$slurp
}
###
# Builds the html version out of a CNFNode.
-# CNFNode with specific tags here are converted also here,
+# CNFNode with specific tags here are converted also here,
# those that are out of the scope for normal standard HTML tags.
# i.e. HTML doesn't have row and cell tags. Neither has meta links syntax.
###
$bf .= "\t"x$tabs."<div".placeAttributes($node).">\n"."\t"x$tabs."<div>";
foreach my $n($node->nodes()){
if($n->{'_'} ne '#'){
- my $b = build($parser, $n, $tabs+1);
+ my $b = build($parser, $n, $tabs+1);
$bf .= "$b\n" if $b;
}
}
if($node->{'#'}){
my $v = $node->val();
$v =~ s/\n\n+/\<\/br>\n/gs;
- $bf .= "\t<div>\n\t<p>\n".$v."</p>\n\t</div>\n";
+ $bf .= "\t<div>\n\t<p>\n".$v."</p>\n\t</div>\n";
}
$bf .= "\t</div>\t</div>\n"
}elsif( $name eq 'row' || $name eq 'cell' ){
$bf .= "$b\n" if $b;
}
}
- $bf .= $node->val()."\n" if $node->{'#'};
+ $bf .= $node->val()."\n" if $node->{'#'};
$bf .= "\t"x$tabs."</div>"
}elsif( $name eq 'img' ){
$bf .= "\t\t<img".placeAttributes($node)."/>\n";
}elsif($name eq 'list_images'){
my $paths = $node->{'@@'};
- foreach my $ndp (@$paths){
+ foreach my $ndp (@$paths){
my $path = $ndp -> val();
my @ext = split(',',"jpg,jpeg,png,gif");
my $exp = " ".$path."/*.". join (" ".$path."/*.", @ext);
$bf .= qq(\t<div class='row'><div class='cell'>);
$bf .= qq(\t<a href="$enc"><img src="$enc" with='120' height='120'><br>$fn</a>\n</div></div>\n);
}
- }
+ }
}elsif($name eq '!'){
return "<!--".$node->val()."-->\n";
-
+
}elsif($node->{'*'}){ #Links are already captured, in future this might be needed as a relink from here for dynamic stuff?
my $lval = $node->{'*'};
- if($name eq 'file_list_html'){ #Special case where html links are provided.
+ if($name eq 'file_list_html'){ #Special case where html links are provided.
foreach(split(/\n/,$lval)){
$bf .= qq( [ $_ ] |) if $_
}
$bf =~ s/\|$//g;
}else{ #Generic included link value.
#is there property data for it?
- my $prop = $parser->data()->{$node->name()};
+ my $prop = $parser->data()->{$node->name()};
#if not has it been passed as an page constance?
- $prop = $parser -> {$node->name()} if !$prop;
+ $prop = $parser -> {$node->name()} if !$prop;
if ( !$prop ) {
if ( $parser->{STRICT} ) { die "Not found as property link -> " . $node->name()}
else { warn "Not found as property link -> " . $node->name()}
}
else{
my $spaced = 1;
- $bf .= "\t"x$tabs."<".$node->name().placeAttributes($node).">";
- foreach my $n($node->nodes()){
- my $b = build($parser, $n,$tabs+1);
- if ($b){
+ $bf .= "\t"x$tabs."<".$node->name().placeAttributes($node).">";
+ foreach my $n($node->nodes()){
+ my $b = build($parser, $n,$tabs+1);
+ if ($b){
if($b =~/\n/){
$bf =~ s/\n$//gs;
$bf .= "\n$b\n"
}else{
- $spaced=0;
- $bf .= $b;
+ $spaced=0;
+ $bf .= $b;
}
- }
+ }
}
-
+
if ($node->{'#'}){
$bf .= $node->val();
$bf .= "</".$node->name().">";
if(@$_[0] ne '#' && @$_[0] ne '_'){
if(@$_[1]){
$ret .= " ".@$_[0]."=\"".@$_[1]."\"";
- }else{
+ }else{
$ret .= " ".@$_[0]." ";
}
}
###
# HTML converter Plugin from PerlCNF to HTML from TREE instucted properties.
# Processing of these is placed in the data parsers data.
-# Programed by : Will Budic
-# Notice - This source file is copied and usually placed in a local directory, outside of its project.
-# So it could not be the actual or current version, can vary or has been modiefied for what ever purpose in another project.
-# Please leave source of origin in this file for future references.
-# Source of Origin : https://github.com/wbudic/PerlCNF.git
-# Documentation : Specifications_For_CNF_ReadMe.md
-# Open Source Code License -> https://choosealicense.com/licenses/isc/
-#
+###
package HTMLProcessorPlugin;
use strict;
use Exception::Class ('HTMLProcessorPluginException');
use feature qw(signatures);
use Scalar::Util qw(looks_like_number);
-use Date::Manip;
+use Clone qw(clone);
use constant VERSION => '1.0';
-sub new ($class, $fields={Language=>'English',DateFormat=>'US'}){
-
- if(ref($fields) eq 'REF'){
- warn "Hash reference required as argument for fields!"
+sub new ($class, $plugin){
+ my $settings;
+ if($plugin){
+ $settings = clone $plugin; #clone otherwise will get hijacked with blessings.
}
- my $lang = $fields->{'Language'};
- my $frmt = $fields->{'DateFormat'};
- Date_Init("Language=$lang","DateFormat=$frmt");
-
- return bless $fields, $class
+ return bless $settings, $class
}
###
my $v = $_->val();
$bfHDR .= qq(\t<script src="$v"></script>\n);
}
- my $ps = $link -> find('STYLE');
- $style = "\n<style>\n". $ps -> val()."</style>" if($ps);
- $ps = $link -> find('JAVASCRIPT');
- $jscript = "\n<script>\n". $ps -> val()."</script>" if($ps);
+ # Glob find '/*' now has guaranteed array cast derefence return. Even if nothing found. Some folks will cringe on that. Ahahaha!
+ $arr = $link -> find('STYLE/*');
+ foreach (@$arr){
+ $style = "\n<style>\n". $_ -> val()."</style>"
+ }
+ $arr = $link -> find('JAVASCRIPT/*');
+ foreach (@$arr){
+ $jscript = "\n<script>\n". $_ -> val()."</script>"
+ }
}
delete $tree -> {'HEADER'};
-1;
\ No newline at end of file
+1;
+
+=begin copyright
+Programed by : Will Budic
+EContactHash : 990MWWLWM8C2MI8K (https://github.com/wbudic/EContactHash.md)
+Source : https://github.com/wbudic/PerlCNF.git
+Documentation : Specifications_For_CNF_ReadMe.md
+ This source file is copied and usually placed in a local directory, outside of its repository project.
+ So it could not be the actual or current version, can vary or has been modiefied for what ever purpose in another project.
+ Please leave source of origin in this file for future references.
+Open Source Code License -> https://github.com/wbudic/PerlCNF/blob/master/ISC_License.md
+=cut copyright
\ No newline at end of file
$ln =~ s/^\s*\>+//;
($ln =~ /^(\s+) (\d+) \.\s (.*)/x || $ln =~ /^(\s*) ([-+*]) \s(.*)/x);
if($2 && $2 =~ /[-+*]/){
- $bqte_tag = "ul";
+ $bqte_tag = "ul"
}elsif($2){
- $bqte_tag = "ol";
+ $bqte_tag = "ol"
}else{
- $bqte_tag = "p";
+ $bqte_tag = "p"
}
if(!$bqte_nested){
$bqte_nested = $nested;
my $feed = $cgi->param('feed') if $cgi;
$parser->log("Feed request:$feed");
for my $idx (0 .. $#data){
- my @col = @{$data[$idx]};
+ my @col = @{$data[$idx]};
if($idx==0){
for my $i(0..$#col){ # Get the matching table column index names as scripted.
$hdr{$col[$i]} = $i
);
pnl.show();
pnl.css('visibility','visible');
+ if(ID === "#feeds"){
$(document).scrollTop( $("#rss_anchor").offset().top );
+ }
$.post('CNFServices.cgi', {service:'feeds',action:'list'}, displayFeeds).fail(
function(response) {
pnl.html(response.responseText);
$.post('CNFServices.cgi', {service:'feeds', action:'read', feed:feed}, displayFeeds).fail(
function(response) {
pnl.html(response.responseText);
- pnl.fadeOut(20000);
+ pnl.fadeOut(30000);
}
);
}
pnl.html(content);
$("#index-content").css("height",'100%');
pnl.show();
- $(document).scrollTop( $("#rss_anchor").offset().top );
+ if(ID === "#feeds"){
+ $(document).scrollTop( $("#rss_anchor").offset().top );
+ }
}
function demoLogin() {
$('#frm_login input[name=passw]').val("admin");
form.submit();
}
+
+function contactForm(){
+ var pnl = $(ID);
+ $.post('CNFServices.cgi', {service:'contacts', action:'form'},
+ function(content){
+ pnl.html(content);
+ pnl.css('visibility','visible');
+ pnl.show();
+ }).fail(
+ function(response) {
+ pnl.html(response.responseText);
+ pnl.fadeOut(30000);
+ }
+ );
+}
+function contact(contact,echsh){
+ $("#frm_contact input[name=poster_contacts]").val(contact);
+ $("#frm_contact input[name=echsh]").val(echsh);
+ var pnl = $('#div_contact');
+ pnl.show();
+ pnl.css('visibility','visible');
+ return false;
+}
\ No newline at end of file
padding:0;
}
p {
- font-family: Bookman;
- margin-left: 70px;
- font-weight: normal;
+ margin-left: 70px;
+ font-weight: bold;
}
pre{
color: #070707;
background: #ccffff;
margin-top: 15px;
margin-left: 200px;
- width: 400px;
+ width: 280px;
text-decoration-style: wavy;
}
border: 1px solid black;
border-right: 1px solid black;
text-align: center;
+ margin:0;
+ padding: 3px;
}
.edit {
margin-left: 91%;
}
+#menu_page {
+ border: 2px solid #10c69b72;
+}
+.marg-top-2{
+ margin-top: 5px;
+}
+
#frm_login {
vertical-align: middle;
margin: 0;
}
+.ui-icon,.menu_title {
+ background-color: transparent;
+ font-weight: bolder;
+}
+.ui-button {
+ font-size: 12px !important;
+ outline-color: transparent;
+}
+.ui-button:hover {
+ background: #00ddfa79;
+ background-image: none;
+ color: #000000 !important;
+}
+.ui-selectmenu-button:{
+ background-image: none;
+}
+.ui-selectmenu-button:hover{
+ background-image: none;
+ background: #00ddfa;
+}
+
-.ui-button,
-.ui-button-text .ui-button {
- font-size: 12px !important;
-}
+
+.ui-widget.ui-widget-content {
+ border: 1px solid #131311;
+ color: #362b36;
+ font-weight: bold;
+}
+.ui-widget-content {
+ background: #183c76;
+ color: #362b36;
+}
.ui-menu {
list-style: none;
padding: 10px;
lifelog.hopto.org / LifeLog.git / commitdiff