From: Will Budic Date: Wed, 26 Jul 2023 12:57:07 +0000 (+1000) Subject: dev. X-Git-Url: https://lifelog.hopto.org/gitweb/?a=commitdiff_plain;h=2846c690b3172a4620164d08a6208e7feb251c98;p=LifeLog.git dev. --- diff --git a/Installation.txt b/Installation.txt index 58e39a8..21cf808 100644 --- a/Installation.txt +++ b/Installation.txt @@ -7,6 +7,7 @@ -- Note - Perl and some modules might take time to install as they are fetched and tested for your computer. + - Provided sudo ./install.sh will do most stuff for you explained in this old doc. @@ -30,7 +31,7 @@ sudo cpan DBD::SQLite; ## # To compile install from source latest Perl Language Interpreter, to local home. -# Note I do not recomended now to compile build install +# Note I do not recommended now to compile build install # for the whole system, if it comes with perl. Systems can come and go. # Your $HOME directory is important. # diff --git a/htdocs/cgi-bin/docs/PerlCNF/README.md b/htdocs/cgi-bin/docs/PerlCNF/README.md index caaf511..64f0aae 100644 --- a/htdocs/cgi-bin/docs/PerlCNF/README.md +++ b/htdocs/cgi-bin/docs/PerlCNF/README.md @@ -6,14 +6,20 @@ CNF file format supports used format extraction from any text file. Useful for templates and providing initial properties and values for an application settings. Has own textual data format. Therefore, can also be useful for database data batch processing. -This version doesn't parse the actual __DATA__ section of a perl file yet. Contact me if this is needed, and for any other possible, useful requests. -It is at current v.2.6, and specification implemented. +This project also contains a custom build TestManager module for general and all test driven development. +It is at current v.2.9, and specification implemented. -[You can find the specification here.](https://github.com/wbudic/PerlCNF/blob/master/Specifications_For_CNF_ReadMe.md) +[You can find the original up-to-date specification here.](https://github.com/wbudic/PerlCNF/Specifications_For_CNF_ReadMe.md) --- - -NEWS (2022-11-18) - PerlCNF now provides custom test manager and test cases. +## Status +(2023-14-6) - v.2.9, new meta flags and priority can be set via these pre-evaluation settings for instructions. + Node processing on demand and JSON translation on demand of CNFNode's (TREE instruction) is now available. + Online demo made available. +(2023-5-13) - v.2.8, has new instructions VARIABLE, to streamline under one tag like CONST, but for anons. +Has better tag mauling algorithm. PLUGIN code has been improved, particularly the synchronizing and the linking of properties. + +(2022-11-18) - PerlCNF now provides custom test manager and test cases. That will in future be used for all projects as an copy from this project. This is all available in the ./test directory and is not a Perl module. @@ -42,16 +48,16 @@ This is all available in the ./test directory and is not a Perl module. * From your project you can modify and adopt, access it. * You can also make an perl bash script. -```perl -use lib "system/modules"; -use lib $ENV{'PWD'}.'/htdocs/cgi-bin/system/modules'; -require CNFParser; + ```perl + use lib "system/modules"; + use lib $ENV{'PWD'}.'/htdocs/cgi-bin/system/modules'; + require CNFParser; - my $cnf1 = new CNFParser('sample.cnf'); - #Load config with enabled evaluation on the fly, of perl code embedded in config file. - my $cnf2 = new CNFParser('sample.cnf',{DO_enabled=>1, duplicates_overwrite=0}); + my $cnf1 = new CNFParser('sample.cnf'); + #Load config with enabled evaluation on the fly, of perl code embedded in config file. + my $cnf2 = new CNFParser('sample.cnf',{DO_enabled=>1, duplicates_overwrite=0}); -``` + ``` ## Sample CNF File diff --git a/htdocs/cgi-bin/docs/PerlCNF/Specifications_For_CNF_ReadMe.md b/htdocs/cgi-bin/docs/PerlCNF/Specifications_For_CNF_ReadMe.md index 083ae8f..2d63d09 100644 --- a/htdocs/cgi-bin/docs/PerlCNF/Specifications_For_CNF_ReadMe.md +++ b/htdocs/cgi-bin/docs/PerlCNF/Specifications_For_CNF_ReadMe.md @@ -27,9 +27,9 @@ Quick Jump: [CNF Tag Formats](#cnf-tag-formats) | [CNF Collections Formatting] 4. Multi line values are tag ended on a separate line with an **>>>**. 5. CNF tag value can post processed by placing macros making it a template. 6. Standard markup of a macro is to enclose the property name or number with a triple dollar signifier **\$\$\$**{macro}**\$\$\$**. - 1. Precedence of resolving the property name/value is by first passed macros, then config anons and finally the looking up constance's. + 1. Precedence of resolving the property name/value is by first passed macros, then config anons and finally the looking up in constants. 2. Nested macros resolving from linked in other properties is currently not supported. -7. CNF full tag syntax format: **```<<{$|@|%}NAME{}{}>>```**, the name and instruction parts, sure open but don't have to be closed with **>** on a multiple line value. +7. CNF full tag syntax format: ```<<{$|@|%}NAME{}{}>>```, the name and instruction parts, sure open but don't have to be closed with **>** on a multiple line value. 8. CNF instructions and constants are uppercase. 1. Example 1 format with instruction: ```<<>>``` autonomous const, with inner properties. 2. Example 2 format with instruction: ```<<{$sig}{NAME}>>``` A single const property with a multi line value. @@ -119,7 +119,7 @@ Quick Jump: [CNF Tag Formats](#cnf-tag-formats) | [CNF Collections Formatting] 3. It is not recommended to use reserve anons as their value settings, that is; can be modified in scripts for their value. 4. Reserve anon if present is usually a placeholder, lookup setting, that in contrast if not found there, might rise exceptions from the application using CNF. - ```CNF Example 2: + ```CNF Example 3: Notice to Admin, following please don't modify in any way! Start --> { <<^RELEASE>2.3>> @@ -235,11 +235,11 @@ Quick Jump: [Introduction](#introduction) | [CNF Tag Formats](#cnf-tag-formats) 2. For arrays, values are delimited by new line or a comma. 3. White space is preserved if values are quoted, otherwise are trimmed. - ```text + ```cnf Format: <<@<{T}NAME{$$}>DATA>>> Examples: - # Following provides an array of listed animal types. + # Following provides an array of listed animal types. Notice how you don't need text to be quoted. <<@<@animals>> # Following provides an array with numbers from 0..8 <<@<@numbers<1,2,3,4,5 @@ -381,7 +381,7 @@ CNF supports basic SQL Database structure statement generation. This is done via 4. The same principles apply in the file as to the DATA instruction CNF tag format, that is expected to be contained in it. ```CNF - < + <> ``` 3. PLUGIN @@ -437,7 +437,7 @@ CNF supports basic SQL Database structure statement generation. This is done via 1. The value of a property is delimited with an [ **#** ] tag as start, end [ **/#** ] as the ending. 1. Each property's start and end tag must stand and be on its own line, withing the body, except for the value or array attributes. 2. A value tagged property section is its text and can't contain further nested tree notes. - ``` Invalid: [#[<**>]#] ``` + Invalid: ```[#[<**>]#] ``` 3. Tree can contain links to other various properties, anons, that means also to other trees then the current one. 1. A link (pointer) to an outside anon or property is specified in form of ⇾ ``` [*[ {path/name} ]*] ```. 1. The link can read only point to: diff --git a/htdocs/cgi-bin/index.cgi b/htdocs/cgi-bin/index.cgi index 7110fe1..de3a8dc 100755 --- a/htdocs/cgi-bin/index.cgi +++ b/htdocs/cgi-bin/index.cgi @@ -33,7 +33,6 @@ BEGIN { use lib "system/modules"; require CNFParser; require CNFNode; -require MarkdownPlugin; our $GLOB_HTML_SERVE = "'{}/*.cgi' '{}/*.htm' '{}/*.html' '{}/*.md' '{}/*.txt'"; our $script_path = $0; $script_path =~ s/\w+.cgi$//; @@ -46,9 +45,9 @@ sub HTMLPageBuilderFromCNF { $script_path."index.cnf",{ DO_ENABLED => 1, HAS_EXTENSIONS=>1, ANONS_ARE_PUBLIC => 1, - PAGE_HEAD => "

Index Page of Docs Directory

", - PAGE_CONTENT => $html, - PAGE_FOOT => "" + PAGE_HEAD => "

Index Page of Docs Directory

", + PAGE_CONTENT => $html, + PAGE_FOOT => "" } ); my $ptr = $cnf->data(); diff --git a/htdocs/cgi-bin/index.cnf b/htdocs/cgi-bin/index.cnf index 40da716..ef8fa9a 100644 --- a/htdocs/cgi-bin/index.cnf +++ b/htdocs/cgi-bin/index.cnf @@ -24,16 +24,16 @@ [#[ #container{ border: 2px solid #00000017; - width: 78%; + width: 78%; margin: 0 auto; - padding: 0px; + padding: 0px; } #header { border: 1px solid gray; - background: rgba(128,128,128,0.2); + background: rgba(128,128,128,0.2); margin:5px; - } + } #content { border: 1px solid gray; @@ -42,14 +42,14 @@ margin:5px; background: rgba(128,128,128,0.2); } - - #content ul { - padding-left: 20px; + + #content ul { + padding-left: 20px; } #content li { - padding: 0px; + padding: 0px; margin-left:30px; - } + } #content li a:link { font-weight: normal; @@ -70,7 +70,7 @@ #footer { border: 1px solid gray; - background: rgba(128,128,128,0.2); + background: rgba(128,128,128,0.2); margin:5px; } @@ -81,24 +81,23 @@ padding: 10px; margin: 5px; text-align: left; } - - .md_doc ul{ + + .md_doc ul{ font-size: large; } .md_doc p{ margin: 0 auto; - padding: 5px; + padding: 5px; vertical-align: left; - text-align: left; + text-align: left; font-weight: normal; - } .md_doc blockquote { margin-top: 0; - margin-bottom: 16px; - background:#b2f8ef; + margin-bottom: 16px; + background:#b2f8ef; border-left: 3px solid #94cde7; border-top: 2px solid #94cde7; border-right: 2px solid #94cde7; @@ -107,15 +106,14 @@ border-bottom: 2px solid #94cde7; } - .div_img{ + .div_img{ height:450px; } + .md_img{ - width:80%; height:80%; } - code, pre{ font-family: 'Droid Sans Mono', 'monospace', monospace; } @@ -124,12 +122,17 @@ border:1px solid black; background: rgba(255,255,255,0.2); padding:15px; - text-align: left; + text-align: left; } .sh{ - background: black; + background: black; color: lightgreen; - padding:15px; + padding: 15px; + width: auto; + border-radius: .32em; + border: 2px solid lightgreen; + margin: inherit; + margin-right: 30px; } div .html { @@ -143,10 +146,11 @@ div .cnf { border:1px solid lightgray; background: rgba(255,255,255,0.2); - padding:10px; + padding:10px; font-family:monospace; text-align: left; padding-bottom: 10px; + margin-right: 30px; margin-top:5px; } @@ -166,17 +170,18 @@ font-size:small; padding: 3px; padding-left: 5px; - padding-right: 5px; + padding-right: 5px; } div .perl { border:1px solid lightgray; background: rgba(149, 215, 172, 0.2); - padding-left:5px; + padding-left:15px; font-family:monospace; - text-align: left; - padding-bottom: 10px; + text-align: left; + padding-bottom: 20px; + margin-right: 30px; } .perl h1{ @@ -185,17 +190,17 @@ margin-top: -10px; height: 20px; line-height: 20px; - font-size: 15px; + font-size: 15px; } - .perl h1 span{ + .perl h1 span{ background: rgba(170, 227, 191, 0.75); border:1px solid lightgray; color:black; font-size:small; padding: 3px; padding-left: 5px; - padding-right: 5px; + padding-right: 5px; } .span_status { @@ -204,7 +209,7 @@ border: 2px solid #94cde7; padding: 5px; text-align: center; - background: #ccffff; + background: #ccffff; text-decoration-style: wavy; filter: drop-shadow( 10px 8px 5px #3e6f70); } @@ -226,14 +231,14 @@ function onIndexBodyLoad(){ function(e){ e.preventDefault(); e.target.setAttribute("style","color: rgb(136, 58, 200);font-weight: bolder;font-style: italic"); - $("#status").html("Loading: " + e.target.href).show().fadeOut(3000); + $("#status").html("Loading: " + e.target.href).show().fadeOut(3000); $.post('index.cgi', {action:'load', doc:e.target.getAttribute('href')}, loadDocResult).fail( function(response) {$('#doc_display').html("Service Error: "+response.status,response.responseText)} ); } ); $("#content a").prop("visitied",false); - onBodyLoadGeneric(); + onBodyLoadGeneric(); } function loadDocResult(content){ $('#doc_display').html(content); @@ -247,7 +252,7 @@ function loadDocResult(content){ ### -# We in plugin mainly access this PAGE property, <*
*> is linked in for clarity, +# We in plugin mainly access this PAGE property, <*
*> is linked in for clarity, # and/or if want to change from keeping the original \<\...\>\> above. # < @@ -257,7 +262,7 @@ function loadDocResult(content){ Title: Index Page OnLoad : onIndexBodyLoad() - @@ -267,15 +272,15 @@ function loadDocResult(content){
- Index
+ Index
Life Log ->#> +>#> >div> *> *> - >div> + >div> *> - >div> - >div> + >div> + >div> *> span> #> >a> span> a> + >a> >div> >div> !> >>PAGE>TREE> + < +**Now, if you please, select a link from the directory listing above.** ### INFO \> This Page is the Documentation listing coming with the [LifeLog](https://github.com/wbudic/LifeLog) Application. \> \>[Open Source License](https://choosealicense.com/licenses/isc/) +
Page brought to you by HTMLIndexProcessorPlugin v.<**> in Moon Stage (beta).
+ >> < diff --git a/htdocs/cgi-bin/login_ctr.cgi b/htdocs/cgi-bin/login_ctr.cgi index 5670334..332ef59 100755 --- a/htdocs/cgi-bin/login_ctr.cgi +++ b/htdocs/cgi-bin/login_ctr.cgi @@ -20,13 +20,13 @@ BEGIN { my $msg = shift; print "

LifeLog Server Error

"; print "
@[$ENV{PWD}].Error: $msg
"; - + } set_message(\&handle_errors); } my $cgi = CGI->new(); -my $session = CGI::Session->new("driver:File",$cgi, {Directory=>&Settings::logPath, SameSite=>'Lax'}); +my $session = CGI::Session->new("driver:File",$cgi, {Directory=>&Settings::logPath, SameSite=>'Lax'}); my $sssCreatedDB = $session->param("cdb"); my $sid=$session->id(); my $cookie = $cgi->cookie(CGISESSID => $sid); @@ -48,15 +48,15 @@ my $VW_OVR_WHERE=""; my $LOGOUT_RELOGIN_TXT='No, no, NO! Log me In Again.'; my $LOGOUT_IFRAME_ENABLED = 0; my $LOGOUT_IFRAME = qq| - |; my %reserved = ('AND'=>1, 'OR'=>1, 'NOT'=>1, 'DATE'=>1,'OLDER_THAN'=>1, 'FROM'=>1,'TO'=>1,'>'=>1,'<'=>1,'>='=>1,'<='=>1,'=='=>1,'!='=>1); -my %columns = ('CAT'=>1,'STICKY'=>1, 'RTF'=>1, 'LOG'=>1); -try{ +my %columns = ('CAT'=>1,'STICKY'=>1, 'RTF'=>1, 'LOG'=>1); +try{ checkAutologinSet(); logout() if($cgi->param('logout')); - if(processSubmit()==0){ + if(processSubmit()==0){ my ($css,$colBG,$colSHDW) = (Settings::theme('css'),Settings::theme('colBG'),Settings::theme('colSHDW')); print $cgi->header(-expires=>"0s", -charset=>"UTF-8", -cookie=>$cookie); print $cgi->start_html( @@ -78,8 +78,8 @@ try{ $hst = `hostname` . "($ht[0])" if (@ht); $frm = < - +
@@ -101,17 +101,20 @@ try{
Welcome to Life Log
Host -> $hst
HTML - print qq(

+ print qq( +
+ ); @@ -131,7 +134,7 @@ HTML my $dbg = ""; my $pwd = `pwd`; $pwd =~ s/\s*$//; - $dbg = "--DEBUG OUTPUT--\n$DBG" if Settings::debug(); + $dbg = "--DEBUG OUTPUT--\n$DBG" if Settings::debug(); print $cgi->header, "
SERVER ERROR on $now". "
".$pwd."/$0 -> [\n$err]","\n$dbg
", @@ -140,7 +143,7 @@ HTML exit; sub processSubmit { - if($alias&&$passw){ + if($alias&&$passw){ $pass = $passw; $passw = uc crypt $passw, hex Settings->CIPHER_KEY; #CheckTables will return 1 if it was an logout set in the config table. To bypass redirection. if(checkCreateTables()==0){ @@ -148,8 +151,8 @@ sub processSubmit { $session->param('passw', $passw); $session->param('db_source', Settings::dbSrc()); $session->param('db_file', Settings::dbFile()); - $session->param('database', Settings::dbName()); - $session->expire(Settings::sessionExprs()); + $session->param('database', Settings::dbName()); + $session->expire(Settings::sessionExprs()); $session->flush(); ### To MAIN PAGE print $cgi->header(-expires=>"0s", -charset=>"UTF-8", -cookie=>$cookie, -location=>"main.cgi"); @@ -178,7 +181,7 @@ sub checkAutologinSet { if($v){$BACKUP_ENABLED = $v; next} $v = Settings::parseAutonom('DBI_SOURCE',$line); if($v){Settings::dbSrc($v); next} - $v = Settings::parseAutonom('AUTO_SET_TIMEZONE',$line); + $v = Settings::parseAutonom('AUTO_SET_TIMEZONE',$line); if($v){$AUTO_SET_TIMEZONE = $v; next} $v = Settings::parseAutonom('DBI_LOG_VAR_SIZE',$line); if($v){Settings::dbVLSZ($v); next} @@ -193,7 +196,7 @@ sub checkAutologinSet { $TIME_ZONE_MAP .= $line . "\n"; } next; - } + } $v = Settings::parseAutonom('PAGE_VIEW_EXCLUDES',$line); if($v){$PAGE_EXCLUDES=$v;next} $v = Settings::parseAutonom('VIEW_OVERRIDE_SYSLOGS',$line); @@ -217,21 +220,21 @@ sub checkAutologinSet { return; # Note, we do assign entered password even passw as autologin is set. Not entering one bypasses this. } # If stricter access is required set it to zero in main.cnf, or disable in config. $passw = $cre[1] if (!$passw); - $db = Settings::connectDB($alias, $passw); + $db = Settings::connectDB($alias, $passw); #check if autologin enabled. - my $st = Settings::selectRecords($db,"SELECT VALUE FROM CONFIG WHERE NAME='AUTO_LOGIN';"); + my $st = Settings::selectRecords($db,"SELECT VALUE FROM CONFIG WHERE NAME='AUTO_LOGIN';"); if($st){ my @set = $st->fetchrow_array(); if($set[0]=="1"){ $alias = $cre[0]; - $passw = $passw; + $passw = $passw; Settings::removeOldSessions(); } $st->finish(); } $db -> disconnect(); } - Settings::loadLastUsedTheme(); + Settings::loadLastUsedTheme(); } sub checkPreparePGDB { @@ -245,7 +248,7 @@ sub checkPreparePGDB { } if($create){ # TODO Default expected to exist db is postgres, username and password. This cgi connects locally. - # Modify this to take any other situations or create main.cnf anon properties for all this. + # Modify this to take any other situations or create main.cnf anon properties for all this. # To the user with roes and database creation powers. my $db = DBI->connect('dbi:Pg:dbname=postgres;host=localhost','postgres', 'postgres'); Settings::debug(1); @@ -262,7 +265,7 @@ sub checkPreparePGDB { )); $db->do(qq( CREATE DATABASE $alias - WITH + WITH OWNER = $alias ENCODING = 'UTF8' LC_COLLATE = 'en_AU.UTF-8' @@ -272,22 +275,22 @@ sub checkPreparePGDB { )); $db->disconnect(); undef $db; return 1; - } + } return 0; } sub checkCreateTables { my ($pst, $sql,$rv, $changed) = ("","","",0); try{ # We live check database for available tables now only once. - # If brand new database, this sill returns fine an empty array. + # If brand new database, this sill returns fine an empty array. my %curr_config = (); - my %curr_tables; - $changed = checkPreparePGDB() if Settings::isProgressDB(); - $db = Settings::connectDB($DB_NAME, $alias, $passw); - %curr_tables = %{Settings::schema_tables($db)}; + my %curr_tables; + $changed = checkPreparePGDB() if Settings::isProgressDB(); + $db = Settings::connectDB($DB_NAME, $alias, $passw); + %curr_tables = %{Settings::schema_tables($db)}; if($curr_tables{'CONFIG'}) { - #Set changed if the configuration data has been wiped out, i.e. by db fix routines. + #Set changed if the configuration data has been wiped out, i.e. by db fix routines. $pst = Settings::selectRecords($db,"SELECT NAME, VALUE FROM CONFIG;"); my @r = $pst->fetchrow_array(); if(@r){ @@ -305,17 +308,17 @@ sub checkCreateTables { my ($pst, $sql,$rv, $changed) = ("","","",0); #has alter table CONFIG add DESCRIPTION VCHAR(128); $rv = $db->do(Settings::createCONFIGStmt()); $changed = 1; - } + } # Now we got a db with CONFIG, lets get settings from THERE. # Default version is the scripted current one, which could have been updated. # We need to maybe update further, if these versions differ. - # Source default and the one from the CONFIG table in the (present) database. + # Source default and the one from the CONFIG table in the (present) database. Settings::getConfiguration($db,{ backup_enabled=>$BACKUP_ENABLED,#<-actual anon property value has been overriden here via &checkAutologinSet. auto_set_timezone=>$AUTO_SET_TIMEZONE, - TIME_ZONE_MAP=>$TIME_ZONE_MAP, + TIME_ZONE_MAP=>$TIME_ZONE_MAP, db_log_var_limit=>Settings::dbVLSZ() - }); + }); my $DB_VERSION = Settings::release(); #$After loading of config this has now been changed to the current database one. my $hasLogTbl = $curr_tables{'LOG'}; my $hasNotesTbl = $curr_tables{'NOTES'}; @@ -339,9 +342,9 @@ sub checkCreateTables { my ($pst, $sql,$rv, $changed) = ("","","",0); } if($hasLogTbl){ - if(Settings::isProgressDB()){ + if(Settings::isProgressDB()){ #Has the DBI_LOG_VAR_SIZE been changed? For Pg it is important. Default code value is in Settings::DBI_LVAR_SZ - my $v = Settings::dbVLSZ(); + my $v = Settings::dbVLSZ(); if($curr_config{db_log_var_limit} ne $v){ #<- yes, crap, a different mapping name in the db for the anon DBI_LOG_VAR_SIZE if($v>1024){#<-We actually only care that what is set in script is an number value to have to further modify anything. Settings::configProperty($db,0,'db_log_var_limit',$v); @@ -352,11 +355,11 @@ sub checkCreateTables { my ($pst, $sql,$rv, $changed) = ("","","",0); $db->do(Settings::createViewLOGStmt()) if $curr_tables{Settings->VW_LOG}; } } - } + } else{ #Is it pre or around v.2.1, where ID_RTF is instead of RTF in the LOG table? $pst = Settings::selectRecords($db, "SELECT * from pragma_table_info('LOG') where name like 'ID_RTF';"); - my @row = $pst = $pst->fetchrow_array(); + my @row = $pst = $pst->fetchrow_array(); if(scalar (@row)>0 &&$row[0]==1){ $sql="ALTER TABLE LOG RENAME COLUMN ID_RTF TO RTF;"; Settings::selectRecords($db, $sql);#<-will make a prepared stmt do, but also with exsception handling. @@ -386,7 +389,7 @@ sub checkCreateTables { my ($pst, $sql,$rv, $changed) = ("","","",0); $sql_date = DateTime::Format::SQLite->parse_datetime($sql_date); if(Settings::isProgressDB()){ $sql="SELECT ID, DATE FROM life_log_login_ctr_temp_table WHERE RTF > 0 AND DATE = '".$sql_date."';"} - else{$sql="SELECT rowid, DATE FROM life_log_login_ctr_temp_table WHERE RTF > 0 AND DATE = '".$sql_date."';"} + else{$sql="SELECT rowid, DATE FROM life_log_login_ctr_temp_table WHERE RTF > 0 AND DATE = '".$sql_date."';"} my $pst2 = Settings::selectRecords($db, $sql); my @rec = $pst2->fetchrow_array(); if(@rec){ @@ -404,7 +407,7 @@ sub checkCreateTables { my ($pst, $sql,$rv, $changed) = ("","","",0); } if($DB_VERSION > 1.6){ #is above v.1.6 notes table. - $db->do('DROP TABLE '.Settings->VW_LOG); + $db->do('DROP TABLE '.Settings->VW_LOG); } $db->do('DROP TABLE LOG;'); #v.1.8 Has fixes, time also properly to take into the sort. Not crucial to drop. @@ -450,8 +453,8 @@ sub checkCreateTables { my ($pst, $sql,$rv, $changed) = ("","","",0); elsif($hasLogTbl && $SCRIPT_RELEASE > $DB_VERSION && $DB_VERSION < 2.2){ my $t ="BYTE"; $t = "SMALLINT" if Settings::isProgressDB(); $db->do("ALTER TABLE LOG ADD COLUMN RTF $t default 0");$changed = 1; - } - elsif($SCRIPT_RELEASE > $DB_VERSION){$changed = 1;} + } + elsif($SCRIPT_RELEASE > $DB_VERSION){$changed = 1;} if(!$hasLogTbl) { @@ -465,8 +468,8 @@ sub checkCreateTables { my ($pst, $sql,$rv, $changed) = ("","","",0); $db->do(Settings::createLOGStmt()); - my $st = $db->prepare('INSERT INTO LOG(ID_CAT,DATE,LOG) VALUES (?,?,?)'); - $st->execute( 3, Settings::today(), "DB Created!"); + my $st = $db->prepare('INSERT INTO LOG(ID_CAT,DATE,LOG) VALUES (?,?,?)'); + $st->execute( 3, Settings::today(), "DB Created!"); $session->param("cdb", "1"); } @@ -476,7 +479,7 @@ sub checkCreateTables { my ($pst, $sql,$rv, $changed) = ("","","",0); $db->do(Settings::createViewLOGStmt()) or LifeLogException -> throw("ERROR:".$@); } # From 2.2+ - #Do we need to create, view overrides? + #Do we need to create, view overrides? if($VW_OVR_SYSLOGS){ if($PAGE_EXCLUDES && $PAGE_EXCLUDES =~ /,6,/){ $PAGE_EXCLUDES .= ",6"; @@ -498,7 +501,7 @@ sub checkCreateTables { my ($pst, $sql,$rv, $changed) = ("","","",0); }elsif($curr_config{'^VW_OVR_WHERE'}){Settings::configProperty($db, 206,'^VW_OVR_WHERE',0);} if(!$curr_tables{Settings->VW_LOG_WITH_EXCLUDES}) { - # To cover all possible situations, this test elses too. + # To cover all possible situations, this test elses too. # As an older existing view might need to be recreated, to keep in synch. if($PAGE_EXCLUDES){ $db->do($sql=createPageViewExcludeSQL()); @@ -509,9 +512,9 @@ sub checkCreateTables { my ($pst, $sql,$rv, $changed) = ("","","",0); $db->do('DROP VIEW '.Settings->VW_LOG_WITH_EXCLUDES); $db->do($sql=createPageViewExcludeSQL()); Settings::configProperty($db, 204, '^PAGE_EXCLUDES',$PAGE_EXCLUDES); - + }elsif($curr_config{'^PAGE_EXCLUDES'}){Settings::configProperty($db, 204, '^PAGE_EXCLUDES',0);} - + if(!$curr_tables{'CAT'}) { $db->do($sql=Settings::createCATStmt()); $changed = 1; @@ -532,7 +535,7 @@ sub checkCreateTables { my ($pst, $sql,$rv, $changed) = ("","","",0); $db->do($sql=Settings::createAUTHStmt()); my $st = $db->prepare('INSERT INTO AUTH VALUES (?,?,?,?);'); $st->execute($alias, $passw,"",0); - $st->finish(); + $st->finish(); } Settings::configProperty($db, 222, '^DB_PALS',$pass); # @@ -548,7 +551,7 @@ sub checkCreateTables { my ($pst, $sql,$rv, $changed) = ("","","",0); # if(!$hasNotesTbl) {$db->do($sql=Settings::createNOTEStmt())} - if(Settings::isProgressDB()){ + if(Settings::isProgressDB()){ my @tbls = $db->tables(undef, 'public'); foreach (@tbls){ my $t = uc substr($_,7); @@ -592,23 +595,23 @@ sub checkCreateTables { my ($pst, $sql,$rv, $changed) = ("","","",0); # #Still going through checking tables and data, all above as we might have an version update in code. #Then we check if we are loged in intereactively back. Interective, logout should bring us to the login screen. - # Bypassing auto login. So to start maybe working on another database, and a new session. + # Bypassing auto login. So to start maybe working on another database, and a new session. return 1 if $cgi->param('autologoff') == 1; }catch{ - LifeLogException -> throw(error=>"DSN:".Settings::dsn()." Error:".$@."\nLAST_SQL:".$sql."\npwd:".`pwd`,show_trace=>1); + LifeLogException -> throw(error=>"DSN:".Settings::dsn()." Error:".$@."\nLAST_SQL:".$sql."\npwd:".`pwd`,show_trace=>1); } return 0; } sub createPageViewExcludeSQL { - + my ($where,$days) = 0; my $parse = $PAGE_EXCLUDES; my @a = split('=',$parse); if(scalar(@a)==2){ $days = $a[0]; $parse = $a[1]; - } + } if(Settings::isProgressDB()){$where = "WHERE a.date >= (timestamp 'now' - interval '$days days') OR"} else{$where = "WHERE a.date >= date('now', '-$days day') OR"} @a = split(',',$parse); @@ -616,11 +619,11 @@ sub createPageViewExcludeSQL { $where =~ s/\s+OR$//; $where =~ s/\s+AND$//; return Settings::createViewLOGStmt(Settings->VW_LOG_WITH_EXCLUDES,$where); - + } sub createPageViewWhereOverrideSQL { - + my ($where,$days) = ("",0); my $parse = $PAGE_EXCLUDES; my @a = split('=',$parse); @@ -630,8 +633,8 @@ sub createPageViewWhereOverrideSQL { } @a = split(',',$parse); foreach (@a){ $where .= " ID_CAT!=$_ AND"; } - - @a = toTokens($VW_OVR_WHERE); + + @a = toTokens($VW_OVR_WHERE); foreach (@a){$where .= $_.' '} # my @b = split('=',$_); # if($b[1]){ @@ -642,14 +645,14 @@ sub createPageViewWhereOverrideSQL { # } #OLDER_THAN=2months - #a.date >= date('now', '-24 hour') - + #a.date >= date('now', '-24 hour') + if(Settings::isProgressDB()){$where = "WHERE $where a.date >= (timestamp 'now' - interval '24 hours')"} else{$where = "WHERE $where a.date >= date('now', '-24 hours')"} - + return Settings::createViewLOGStmt(Settings->VW_LOG_OVERRIDE_WHERE,$where); - + } @@ -662,7 +665,7 @@ sub toTokens { if($token eq '=' || $token eq '=\''){ $grp = $prev; next; } - elsif($token=~ /[^!=<>\n]+=$/){ + elsif($token=~ /[^!=<>\n]+=$/){ $grp = $token =~ s/=$//g; next; } elsif($grp){ @@ -670,7 +673,7 @@ sub toTokens { push @ret, $grp; $grp = ""; } else{ - $grp .= ' '.$token; + $grp .= ' '.$token; if($token =~ m/'$/){ $grp .=')'; if($reserved{$prev}){push @ret, $prev} @@ -737,7 +740,7 @@ sub toTokens { $resolve = $token =~ s/^'//g; if($resolve =~ m/'$/){ $token = $resolve =~ s/'$//g; $resolve =""; - }else{next} + }else{next} } elsif($token =~ m/'$/ and $resolve){ $token =~ s/^$//g; @@ -779,14 +782,14 @@ sub populate { my $insCat = $db->prepare('INSERT INTO CAT VALUES (?,?,?)'); $db->begin_work(); foreach my $line (@lines) { - + last if ($line =~ //);#Not doing it with CNF1.0 if( index( $line, '<>/); - + my @tick = split("`",$line); if( scalar @tick == 2 ) { @@ -801,15 +804,15 @@ sub populate { if($vars{$id}){ $err .= "UID{$id} taken by $vars{$id}-> $line\n"; } - else{ - my @arr = Settings::selectRecords($db,"SELECT ID FROM CONFIG WHERE NAME LIKE '$name';")->fetchrow_array(); - $inData = 1; + else{ + my @arr = Settings::selectRecords($db,"SELECT ID FROM CONFIG WHERE NAME LIKE '$name';")->fetchrow_array(); + $inData = 1; if(!@arr) { $DBG .= "conf.ins->".$name.",".$value.",".$tick[1]."\n"; if(Settings::isProgressDB()) {$insCnf->execute($name,$value,$tick[1])} else{$insCnf->execute($id,$name,$value,$tick[1])} } - + } } }else{ @@ -909,8 +912,8 @@ sub logout { $session->delete(); $session->flush(); - my $bckLog = Settings::logPath()."backup_restore.log"; - unlink $bckLog if(-e $bckLog); + my $bckLog = Settings::logPath()."backup_restore.log"; + unlink $bckLog if(-e $bckLog); exit; } diff --git a/htdocs/cgi-bin/system/modules/CNFNode.pm b/htdocs/cgi-bin/system/modules/CNFNode.pm index 6ad5ccc..7136781 100644 --- a/htdocs/cgi-bin/system/modules/CNFNode.pm +++ b/htdocs/cgi-bin/system/modules/CNFNode.pm @@ -272,8 +272,7 @@ sub process { if($tag =~ /^([#\*\@]+)[\[<](.*)[\]>]\/*[#\*\@]+$/){#<- The \/ can sneak in as included in closing tag. if($1 eq '*'){ my $link = $2; - my $rval = $self -> obtainLink($parser, $link); - $rval = $parser->{$link} if !$rval; #Anon is passed as an unknown constance (immutable). + my $rval = $self -> obtainLink($parser, $link); if($rval){ if($opening){ $body .= qq($ln\n); @@ -443,8 +442,7 @@ sub process { else{$val = $4} }elsif($2 eq '*'){ my $link = $4; - my $rval = $self -> obtainLink($parser, $link); - $rval = $parser->{$link} if !$rval; #Anon is passed as an unknown constance (immutable). + my $rval = $self -> obtainLink($parser, $link); if($rval){ #Is this a child node? if(exists $self->{'@'}){ @@ -461,8 +459,7 @@ sub process { else{ #Links scripted in main tree parent are copied main tree attributes. $self->{$link} = $rval - } - + } }else{ warn "Anon link $link not located with '$ln' for node ".$self->{'_'} if !$opening; } @@ -540,12 +537,9 @@ sub obtainLink { use Module::Loaded qw(is_loaded); if(is_loaded($1)){ $ret = \&{+$link}($self); - }else{ - cluck qq(Package constance link -> $link is not available (try to place in main:: package with -> 'use $1;')") } - }else{ - $ret = $parser->anon($link); } + $ret = $parser->obtainLink($link) if !$ret; return $ret; } diff --git a/htdocs/cgi-bin/system/modules/CNFParser.pm b/htdocs/cgi-bin/system/modules/CNFParser.pm index a552b31..8a7c554 100644 --- a/htdocs/cgi-bin/system/modules/CNFParser.pm +++ b/htdocs/cgi-bin/system/modules/CNFParser.pm @@ -44,7 +44,7 @@ our %ANONS; # You probably don't want to use these as your own possible instruction implementation. ### -our %RESERVED_WORDS = map +($_, 1), qw{ CONST CONSTANT VARIABLE VAR +our %RESERVED_WORDS = map +($_, 1), qw{ CONST CONSTANT DATA VARIABLE VAR FILE TABLE TREE INDEX VIEW SQL MIGRATE DO LIB PLUGIN MACRO %LOG INCLUDE INSTRUCTOR }; @@ -1008,6 +1008,33 @@ sub doPlugin { } } +### +# Generic CNF Link utility on this repository. +## +sub obtainLink { + my ($self,$link, $ret) = @_; + my $meths; + ## no critic BuiltinFunctions::ProhibitStringyEval + no strict 'refs'; + if($link =~/(\w*)::\w+$/){ + use Module::Loaded qw(is_loaded); + if(is_loaded($1)){ + $ret = \&{+$link}($self); + }else{ + eval require "$1.pm"; + $ret = &{+$link}; + if(!$ret){ + $self->error( qq(Package constance link -> $link is not available (try to place in main:: package with -> 'use $1;'))); + $ret = $link + } + } + }else{ + $ret = $self->anon($link); + $ret = $self-> {$link} if !$ret; + } + return $ret; +} + ### # Writes out to a handle an CNF property or this parsers constance's as default property. # i.e. new CNFParser()->writeOut(*STDOUT); @@ -1103,12 +1130,12 @@ sub writeOut { my ($self, $handle, $property) = @_; sub log { my $self = shift; my $message = shift; - my $type = shift; + my $type = shift; $type = "" if !$type; my $attach = join @_; $message .= $attach if $attach; my %log = $self -> collection('%LOG'); my $time = DateTime->from_epoch( epoch => time )->strftime('%Y-%m-%d %H:%M:%S.%3N'); $message = "$type $message" if 'WARNG'; - if($message =~ /^ERROR/ || defined($type eq 'WARNG')){ + if($message =~ /^ERROR/ || $type eq 'WARNG'){ warn $time . " " .$message; } elsif(%log && $log{console}){ diff --git a/htdocs/cgi-bin/system/modules/HTMLIndexProcessorPlugin.pm b/htdocs/cgi-bin/system/modules/HTMLIndexProcessorPlugin.pm index aca2573..46fa171 100644 --- a/htdocs/cgi-bin/system/modules/HTMLIndexProcessorPlugin.pm +++ b/htdocs/cgi-bin/system/modules/HTMLIndexProcessorPlugin.pm @@ -12,6 +12,8 @@ use Date::Manip; use CGI; use CGI::Session '-ip_match'; +use constant VERSION => '1.0'; + our $TAB = ' 'x4; sub new ($class, $fields={Language=>'English',DateFormat=>'US'}){ diff --git a/htdocs/cgi-bin/system/modules/HTMLProcessorPlugin.pm b/htdocs/cgi-bin/system/modules/HTMLProcessorPlugin.pm index ba7b641..b455f23 100644 --- a/htdocs/cgi-bin/system/modules/HTMLProcessorPlugin.pm +++ b/htdocs/cgi-bin/system/modules/HTMLProcessorPlugin.pm @@ -19,6 +19,8 @@ use feature qw(signatures); use Scalar::Util qw(looks_like_number); use Date::Manip; +use constant VERSION => '1.0'; + sub new ($class, $fields={Language=>'English',DateFormat=>'US'}){ if(ref($fields) eq 'REF'){ diff --git a/htdocs/cgi-bin/system/modules/MarkdownPlugin.pm b/htdocs/cgi-bin/system/modules/MarkdownPlugin.pm index 100da6e..7166cc0 100644 --- a/htdocs/cgi-bin/system/modules/MarkdownPlugin.pm +++ b/htdocs/cgi-bin/system/modules/MarkdownPlugin.pm @@ -1,9 +1,9 @@ ### -# Ambitious Markup Script converter from MD scripts to HTML. +# This is an Ambitious Markup Script converter from MD scripts to HTML. Every programers nightmare. # MD scripts can thus be placed in PerlCNF properties for further processing by this plugin. # 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. +# Notice - About this source file, it has been 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 @@ -21,6 +21,8 @@ use feature qw(signatures); use Date::Manip; ##no critic ControlStructures::ProhibitMutatingListFunctions +use constant VERSION => '1.0'; + our $TAB = ' 'x4; our $PARSER; ### @@ -35,31 +37,31 @@ use constant { }; -sub new ($class, $fields={Language=>'English',DateFormat=>'US'}){ +sub new ($class, $fields={Language=>'English',DateFormat=>'US'}){ if(ref($fields) eq 'REF'){ warn "Hash reference required as argument for fields!" } my $lang = $fields->{'Language'}; my $frmt = $fields->{'DateFormat'}; - Date_Init("Language=$lang","DateFormat=$frmt"); + Date_Init("Language=$lang","DateFormat=$frmt"); $fields->{'disk_load'} = 0 if not exists $fields->{'disk_load'}; - + return bless $fields, $class } ### # Process config data to contain expected fields and data. ### -sub convert ($self, $parser, $property) { -try{ +sub convert ($self, $parser, $property) { +try{ my ($item, $script) = $parser->anon($property); $PARSER = $parser; die "Property not found [$property]!" if !$item; my $ref = ref($item); my $escaped = 0; $script = $item; if($ref eq 'CNFNode'){ - $script = $item->{script} + $script = $item->{script} }elsif($ref eq 'InstructedDataItem'){ $script = $item->{val}; $escaped = $item->{ins} eq 'ESCAPED' @@ -68,10 +70,10 @@ try{ $script = do { open my $fh, '<:encoding(UTF-8)', $script or MarkdownPluginException->throw("File not avaliable: $script"); local $/; - <$fh>; + <$fh>; }; } - if($escaped){ + if($escaped){ $script =~ s/\\/>/gs; #$script =~ s/\n/
/gs; @@ -79,7 +81,7 @@ try{ my @doc = @{parse($self,$script)}; $parser->data()->{$property} = $doc[0]; $parser->data()->{$property.'_headings'} = $doc[1]; - + }catch($e){ MarkdownPluginException->throw(error=>$e ,show_trace=>1); }} @@ -91,7 +93,7 @@ try{ # @CREATED 20230709 # @TODO possible to be extended ot account for CSS specified bullet types then the HTML default. ### -package HTMLListItem { +package HTMLListItem { sub new{ my $class = shift; my ($type,$item,$spc) = @_; @@ -102,19 +104,19 @@ package HTMLListItem { return exists($self->{parent}) ? $self->{parent} : undef } sub add($self, $item){ - push @{$self->{list}}, $item; + push @{$self->{list}}, $item; $item ->{parent} = $self; - } - sub hasItems($self){ + } + sub hasItems($self){ return @{$self->{list}}>0 } - sub toString($self){ + sub toString($self){ my $t = $self->{type}; my $isRootItem = $self -> {spc} == 0 ? 1 : 0; my $hasItems = $self->hasItems(); my $hasParent = exists($self->{parent}); my $ret = ""; - if ($hasItems) { + if ($hasItems) { if($isRootItem){ $ret = "<$t>\n" } @@ -126,14 +128,14 @@ package HTMLListItem { } foreach my $item(@{$self->{list}}){ if($item->hasItems()){ - $ret .= $item->toString(); + $ret .= $item->toString(); }else{ my $it = $item->{type}; $it = 'li' if $it eq 'ol' || $it eq 'ul'; - $ret .= "<$it>".$item->{item}."\n"; + $ret .= "<$it>".$item->{item}."\n"; } } - if($hasItems){ + if($hasItems){ $ret .= "\n"; $ret .= "\n" if !$isRootItem; } @@ -143,17 +145,18 @@ package HTMLListItem { sub setCodeTag($tag, $class){ if($tag){ - $tag = lc $tag; + $tag = lc $tag; if($tag eq 'html' or $tag eq 'cnf' or $tag eq 'code' or $tag eq 'perl'){ - $class = $tag; - $tag = 'div'; + $class = $tag if !$class; + $tag = 'div' if $tag ne 'code'; }else{ $tag = 'pre' if($tag eq 'sh' or $tag eq 'bash'); } if($tag eq 'perl'){ - $class='perl'; - $tag ='div'; + $class='perl' if !$class; + $tag ='div'; } + $class = lc $class; #convention is that style class to be all lower case like tags. }else{ $tag = $class = 'pre'; } @@ -162,64 +165,76 @@ sub setCodeTag($tag, $class){ sub parse ($self, $script){ try{ - my ($buff, $para, $ol, $lnc); + my ($buff, $para, $ol, $lnc); my $list_end; my $ltype=0; my $nix=0; my $nplen=0; my $list_item; my $list_root; my @titels;my $code = 0; my ($tag, $class); my $pml_val = 0; my ($bqte, $bqte_nested,$bqte_tag); $script =~ s/^\s*|\s*$//; - foreach my $ln(split(/\n/,$script)){ + foreach my $ln(split(/\n/,$script)){ $ln =~ s/\t/$TAB/gs; $lnc++; - if($ln =~ /^```(\w*)\s(.*)```$/g){ - $tag = $1; - $ln = $2; $list_end=0; - my @code_tag = @{ setCodeTag($tag, "") }; - $buff .= qq(<$code_tag[1] class='$code_tag[0]'>$ln\n); - next - }elsif($ln =~ /^\s*```(\w*)/){ - my $bfCode; + if($ln =~ /(.*) `{3}(\w*)\s*(.*)`{3} (.*)/gx){ + my $pret = ""; $pret = $1 if $1; + my $post = ""; $post = $4 if $4; + $tag = 'code'; $tag =$2 if $2; + my $inline = $3; $inline = inlineCNF($inline,""); + my @code_tag = @{ setCodeTag($tag, "") }; + $ln = qq($pret<$code_tag[1] class='$code_tag[0]'>$inline$post\n); + if(!$pret && !$post){ + $buff .= $ln; next; + } + } + elsif($ln =~ /^\s*```(\w*)(.*)/){ + my $bfCode; my $pretext = $2; $pretext ="" if !$2; $pretext .= "
" if $pretext; if(!$tag){ my @code_tag = @{ setCodeTag($1, $1) }; - $class = $code_tag[0]; + $class = $code_tag[0]; $tag = $code_tag[1] if !$tag; } if($code){ - if($para){ + if($para){ $bfCode .= "$para\n" } $bfCode .= ""; undef $para; $code = 0; undef $tag; - if($list_item){ + if($list_item){ $list_item -> {item} = $list_item -> {item} . $bfCode.'
'; $list_item = $list_item -> parent(); next; } }else{ - $bfCode .= "<$tag class='$class'>"; + $bfCode .= "<$tag class='$class'>"; if($class eq 'perl'){ $bfCode .= qq(

Perl

); $code = 2; }else{ if($class eq 'cnf' or $class eq 'html'){ - $bfCode .= '

'.uc($class).'

' + $bfCode .= "

+ ".uc($class). + q(

).$pretext } $code = 1 } } - if($list_item){ + if($list_item){ my $new = HTMLListItem->new('dt', "
$bfCode", $list_item ->{spc}); $list_item -> add($new); $list_item = $new; $list_end=0; }else{ - $buff .= "$bfCode\n"; + $buff .= "$bfCode\n$pretext"; } - }elsif(!$code && $ln =~ /^\s*(#+)\s*(.*)/){ + next + } + if(!$code && $ln =~ /^\s*(#+)\s*(.*)/){ my $h = 'h'.length($1); - my $title = $2; + my $title = $2; $titels[@titels] = {$lnc,$title}; + if($list_root){ # Has been previously gathered and hasn't been buffered yet. + $buff .= $list_root -> toString(); + undef $list_root; + } $buff .= qq(<$h>$title\n" } elsif(!$code && ($ln =~ /^(\s*)(\d+)\.\s(.*)/ || $ln =~ /^(\s*)([-+*])\s(.*)/)){ - my $spc = length($1); my $val = $3 ? ${style($3)} : ""; my $new = HTMLListItem->new(($2=~/[-+*]/?'ul':'ol'), $val, $spc); @@ -229,19 +244,19 @@ try{ $list_root -> add($new); $list_item = $new }elsif($spc>$nplen){ - $list_item -> add($new); + $list_item -> add($new); $list_item = $new; - $nplen = $spc; - }else{ - my $isEq = $list_item->{spc} == $spc; - while($list_item->{spc} >= $spc && $list_item -> parent()){ + $nplen = $spc; + }else{ + my $isEq = $list_item->{spc} == $spc; + while($list_item->{spc} >= $spc && $list_item -> parent()){ $list_item = $list_item -> parent(); last if $isEq - } - $list_item = $list_root if !$list_item; + } + $list_item = $list_root if !$list_item; $list_item -> add($new); - $list_item = $new; - } + $list_item = $new; + } $list_end = 0; }elsif(!$code && $ln =~ /(^|\\G)[ ]{0,3}(>+) ?/){ my $nested = length($2); @@ -265,16 +280,16 @@ try{ $bqte_nested--; } if($ln !~ /(.+)/gm){ - $bqte .= "\n

\n" + $bqte .= "\n

\n" }else{ if($bqte_tag eq 'p'){ $ln =~ s/^\s*//g; $bqte .= ${style($ln)}."
"; }else{ - $ln =~ s/^\s*[-+*]\s*|^\s*\d+\.\s*//g; - $bqte .= "

  • ".${style($ln)}."
  • \n"; + $ln =~ s/^\s*[-+*]\s*|^\s*\d+\.\s*//g; + $bqte .= "
  • ".${style($ln)}."
  • \n"; } - } + } } elsif(!$code && $ln =~ /^\s*\*\*\*/){ if($para){ @@ -289,40 +304,40 @@ try{ if($tag eq 'pre' && $code == 1){ $v =~ s//>/g; - $para .= "$v\n"; + $para .= "$v\n"; }elsif($code == 2){ if($ln =~/^\s*\<+.*>+$/){ - $para .= inlineCNF($v,$spc)."
    \n" + $para .= inlineCNF($v,$spc)."
    \n" }else{ $para .= code2HTML($v)."
    \n" } - }else{ + }else{ $v = inlineCNF($v,$spc); if(length($v) > length($ln)){ $para .= qq($v
    ); next } - $v =~ m/ ^(<{2,3}) ([\$@%]*\w*)$ + $v =~ m/ ^(<{2,3}) ([\$@%]*\w*)$ | ^(>{2,3})$ | (<<) ([\$@%]*\w*) <(\w+)> /gx; if($1&&$2){ - my $t = $1; - my $i = $2; - $t =~ s/$t$i
    "; $pml_val = 1; - next; + next; }elsif($3){ - my $t = $3; - $t =~ s/>/>/g; + my $t = $3; + $t =~ s/>/>/g; $para .= "$t
    \n"; $pml_val = 0; next; }elsif($4&&$5&&6){ - my $t = $4; + my $t = $4; my $v = $5; my $i = $6; $t =~ s/]) - |^(<{2,3}) + |^(<{2,3}) ([\$@%\w]+)\s* <*([^>]+) (>{2,3})$ - + /gx;# and my @captured = @{^CAPTURE}; - + if($5&&$6&&$7&&$8){ my $t = $5; my $v = $6; @@ -347,19 +362,19 @@ try{ my $c = $8; $t =~ s//>/g; - $pml_val = 1; + $pml_val = 1; $para .= "$t$v<$i$c
    "; - + }elsif($5&&$6){ my $t = $5; my $i = $6; $t =~ s/$t$i
    "; - }elsif($1 && $2 && $3){ + }elsif($1 && $2 && $3){ $pml_val = 1; - $para .= "<<$2<\/span>$3>
    "; + $para .= "<<$2<\/span>$3>
    "; }elsif($8){ - my $t = $8; + my $t = $8; $t =~ s/>/>/g; $pml_val = 0; $para .= "$t
    \n"; } @@ -375,14 +390,14 @@ try{ $para .= "$v
    \n"; } } - } + } }else{ if($bqte){ while($bqte_nested-->0){$bqte .="\n"} $para .= $bqte; undef $bqte; } - $para .= ${style($2)}."\n" + $para .= ${style($2)}."\n" } }else{ if($list_root && ++$list_end>1){ @@ -390,7 +405,11 @@ try{ undef $list_root; } elsif($para){ - if($code){ + if($list_item){ + $list_item->{item} = $list_item->{item} . $para; + $list_end=0; + } + elsif($code){ $buff .= $para; }else{ $buff .= qq(

    $para


    \n); @@ -401,12 +420,12 @@ try{ } if($bqte){ while($bqte_nested-->0){$bqte .="\n\n"} - $buff .= $bqte; - } + $buff .= $bqte; + } if($list_root){ - $buff .= $list_root-> toString(); + $buff .= $list_root-> toString(); } - $buff .= qq(

    $para

    \n) if $para; + $buff .= qq(

    $para

    \n) if $para; return [\$buff,\@titels] }catch($e){ @@ -414,37 +433,48 @@ return [\$buff,\@titels] }} sub code2HTML($val){ - my $v=$val; + my ($v,$cmnt)=($val,""); + + $v =~ s/(.*?)(\#.*)/$2<\/span>/g; + if($1 && $2 && $1!~ m/\s+/){ + $v = $1; $cmnt = "$2<\/span>"; + }else{ + return $v if defined $2 and $2 ne $v; + } + my @strs = ($v =~ m/(['"].*?['"])/g); foreach(0..$#strs){ - my $r = $strs[$_]; + my $r = $strs[$_]; $r =~ s/\[/\\[/; + $PARSER->log($r); my $w = "\f$_\f"; $v =~ s/$r/$w/ge; - } - + } + $v =~ s/([,;=\-\+]+)/$1<\/span>/gx; - $v =~ s/(my|our|local|do|use|lib|require|new|while|for|foreach|while|if|else|elsif|eval)/$1<\/span>/g; + $v =~ s/(my|our|local|do|use|lib|require|new|while|for|foreach|while|if|else|elsif|eval)/$1<\/span>/g; $v =~ s/(\$\w+)/$1<\/span>/g; $v =~ s/([\(\)\{\}\[\]] | ->)/$1<\/span>/gx; + foreach(0..$#strs){ - my $w = $strs[$_]; + my $w = $strs[$_]; $w =~ s/(^['"])(.*)(['"]$)/$1<\/span>$2<\/span>$3<\/span>/g; my $r = "\f$_\f"; $v =~ s/$r/$w/ge; - } - - return $v + } + + return "$v$cmnt"; } sub inlineCNF($v,$spc){ - $spc =~ s/\s/ /g; - $v =~ m/ (<{2,3})(.*?)(>{2,3}) (.*) /gmx; - my $oo = $1; + + $v =~ m/(<{2,3})(.*?)(>{2,3})(.*)/g; + my $oo = $1;$oo =~s/\s+//;#<- fall through expression didin't match my $body = $2; my $cc = $3; my $restIfAny = $4; $restIfAny="" if not $restIfAny; - -if (!$body){ + my $len = length($spc); my $spc_o = $spc; $spc_o =~ s/\s/ /g; + if($len>4&&$len<9){$len-=$len-2;$spc = ' 'x$len}else{$spc =~ s/\s/ /g} + if(!$body){ $oo=$cc=""; $body=$v;$v=~/^(<+)/;$oo=$1 if$1; if($v=~m/\[\#\[/){ return "$spc[#[" @@ -463,39 +493,85 @@ if (!$body){ }elsif($v=~m/^>{1}(\w*)>{1}/ && $1){ return "$spc>$1>" }elsif($v=~m/^<\*<.*>\*>$/){ - my $r = ">*>"; + my $r = ">*>"; $body=~s/>\*>$/$r/; - $r = "<*<"; + $r = "<*<"; $body=~s/^<\*>'){ return "$spc>>\n" } else{ - $v=~/(>+)$/;if($1){ - $cc=$1; - #$body =~ s/>/>/g; + $v=~/(>+\s*)$/;if($1){ + $v = $1; $v =~ s/>/>/g; + return "$spc$v" }else{ $oo =~ s/$oo$1" - }elsif($v=~m/^(<{2,3})(.*?)([><])(.*)/){ - return "$spc$oo$1>$2$3"; + if($v=~m/>>>/){ + $v =~ s/>/>/g; return "$v" + }elsif($v=~m/<<<(.*)/){ + return "$spc$oo$1" + }elsif($v=~m/^(<{2,3})(.*?)([><])(.*)/){ + if($4){ + if($PARSER -> isReservedWord($4)){ + $v = "$4" + }else{ + if (!$2){$v = "$4"}else{$v=""} + } + my $t = "$1$2$3"; + my $r = $4; + if($2 =~ /[@%]/){ + if($r =~ /(.*)([><])(.*)/){ + $v = "$spc$t$1"; + $v .= "$2"; + $v .= "$3"; + return $v; + } + }else{ + $v = "$spc$oo$2$3$v"; + if($r =~ /(\w*)\s(.*)/){ + return "$v$1 $2$cc" + }else{ + return $v + } + } + }else{ + $v = "$3" if $3; + } + return "$spc$oo$2$3$v" }else{ - return propValCNF($v) + return $spc_o.propValCNF($v) } } } } +elsif(!$oo && !$cc){ + + $body =~ m/ ^([\[<\#\*\[<]+) (.*?) ([\]>\#\*\]>]+)$ /gmx; + if($1&&$2&&$3){ + $oo=$1; + $body = $2; + $cc=$3; + $oo =~ s//>/g; + $cc =~ s//>/g; + $body =~ s//>/g; + return "$spc$oo$body>$cc"; + } + +}else{ $oo =~ s//>/g; - $body =~ m/ ([@%]<) ([\$@%]?\w+) ([<>]) | + $cc =~ s/>/>/g; +} + $body =~ m/ ([@%<]) ([\$@%]?\w+)? ([<>]) (.*) | ([^<>]+) ([><])? (.*) /gmx; - if($4&&$5&&$6){ + if($5&&$6&&$7){ my ($o,$var,$val, $prop); - $var = $4; $o=$5; $val=$6; + $var = $5; $o=$6; $val=$7; $val =~ /(.*)(>$)/; if($1&&$2){ my $v = $1; my $i = $2; @@ -526,41 +602,56 @@ if (!$body){ $v = "$oo$prop$cc"; } - elsif($4){ - my $t = $4; - if(!$6){ - $t =~ /(\w+)\s+(.*)/; + elsif($5){ + my $t = $5; + if(!$7){ + $t =~ /(\w*)(\\\w*|\s*)(.*)/; my $i = $1; - if($PARSER->isReservedWord($i)){ + if($PARSER->isReservedWord($i)){ $i = "$i" - }else{ + }else{ $i = "$i" - } - my $prop = propValCNF($2); + } + my $prop = propValCNF($2.$3); $v = "$oo$i$prop$cc" }else{ - my $i = $6; - my $c = $7; $c = $8 if !$c; - $t =~ s//>/g if $c; - $v = "$t$i$c"; + $v = "$t$i$c" } - } + } elsif($1 && $2 && $3){ + my $mrk = $1; $mrk ="" if !$mrk; my $ins = $2; my $prop = propValCNF($3); - $v = "$oo$ins<\/span>$prop$cc" + $prop .= propValCNF($4) if $4; + $v = "$oo$mrk$ins$prop$cc" + }elsif($1 && $3 && $4){ + $body = $4; + $oo .= "$1$3"; + $oo =~ s/<])(.*)/; + if($1 && $2 && $3){ + $v = "$oo$1$2$3$cc" + }else{ + $v = "$oo$body$cc" + } } return $spc.$v.$restIfAny } -sub propValCNF($v){ - $v =~ m/(.*)([=:])(.*)/gs; - if($1&&$2&&$3){ - return " $1$2$3"; +sub propValCNF($v){ + my @match = ($v =~ m/(.*)([=:])(.*)/gs); + if(@match){ + return " $1$2$3" + } + elsif($v =~ /[><]/){ + return "$v" }else{ - return " $v"; + return "$v" } return $v; } @@ -570,17 +661,21 @@ sub style ($script){ #Links $script =~ s/<(http[:\/\w.]*)>/$1<\/a>/g; $script =~ s/(\*\*([^\*]*)\*\*)/\$2<\/em\>/gs; + if($script =~m/[<\[]\*[<\[](.*)[\]>]\*[\]>]/){#It is a CNF link not part of standard Markup. + my $link = $1; + my $find = $PARSER->obtainLink($link); + $find = $link if(!$find); + $script =~ s/[<\[]\*[<\[](.*)[\]>]\*[\]>]/$find/gs; + } $script =~ s/(\*([^\*]*)\*)/\$2<\/strong\>/gs; $script =~ s/__(.*)__/\$1<\/del\>/gs; $script =~ s/~~(.*)~~/\$1<\/strike\>/gs; my $ret = $script; - #Inline code - $ret =~ m/```(.*)```/g; - if($1){ + # Inline CNF code handle. + if($ret =~ m/`{3}(.*)`{3}/){ my $v = inlineCNF($1,""); - $ret =~ s/```(.*)```/\$v<\/span\>/; + $ret =~ s/```(.*)```/\$v<\/span\>/; } - #Images $ret =~ s/!\[(.*)\]\((.*)\)/\
    \"$1\"\/<\/div>/; #Links [Duck Duck Go](https://duckduckgo.com) @@ -630,26 +725,31 @@ div .cnf { .kw { color: maroon; - padding: 2px; + padding: 2px; } .bra {color:rgb(247, 55, 55);} .var { - color: blue; + color: blue; } .opr { - color: darkgreen; + color: darkgreen; } .val { - color: gray; + color: gray; } .str { - color: orange; + color: orange; font-style:italic; - font-weight: bold; + font-weight: bold; } .inst { - color: green; - font-weight: bold; + color: green; + font-weight: bold; +} +.cmnt { + color: #025802; + font-style:italic; + font-weight: bold; } /; diff --git a/install.sh b/install.sh index 4053370..5fa31b2 100755 --- a/install.sh +++ b/install.sh @@ -40,3 +40,4 @@ perl -MCPAN -e 'install Perl::LanguageServer' perl -MCPAN -e 'install Log::Log4perl' perl -MCPAN -e 'install Number::Bytes::Human' perl -MCPAN -e 'install File::ReadBackwards' +