-- 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.
##
# 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.
#
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.
* 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
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{<INSTRUCTION>}{<any type of value>}>>```**, 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{<INSTRUCTION>}{<any type of value>}>>```, 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: ```<<<CONST\n{name=value\n..}\n>>>``` autonomous const, with inner properties.
2. Example 2 format with instruction: ```<<{$sig}{NAME}<CONST {multi line value}>>>``` A single const property with a multi line value.
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>>
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<Cat,"Dog","Pigeon",Horse>>>
# Following provides an array with numbers from 0..8
<<@<@numbers<1,2,3,4,5
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
- <<MyItemsTbl<FILE data_my_app.cnf>
+ <<MyItemsTbl<FILE data_my_app.cnf>>
```
3. PLUGIN
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: [#[<*<link/to/something>*>]#] ```
+ Invalid: ```[#[<*<link/to/something>*>]#] ```
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:
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$//;
$script_path."index.cnf",{
DO_ENABLED => 1, HAS_EXTENSIONS=>1,
ANONS_ARE_PUBLIC => 1,
- PAGE_HEAD => "<h1 id=\"index_head\">Index Page of Docs Directory</h1>",
- PAGE_CONTENT => $html,
- PAGE_FOOT => "<!--Not Defined-->"
+ PAGE_HEAD => "<h1 id=\"index_head\">Index Page of Docs Directory</h1>",
+ PAGE_CONTENT => $html,
+ PAGE_FOOT => "<!--Not Defined-->"
}
);
my $ptr = $cnf->data();
[#[
#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;
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;
#footer {
border: 1px solid gray;
- background: rgba(128,128,128,0.2);
+ background: rgba(128,128,128,0.2);
margin:5px;
}
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;
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;
}
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 {
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;
}
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{
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 {
border: 2px solid #94cde7;
padding: 5px;
text-align: center;
- background: #ccffff;
+ background: #ccffff;
text-decoration-style: wavy;
filter: drop-shadow( 10px 8px 5px #3e6f70);
}
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);
###
-# We in plugin mainly access this PAGE property, <*<HEADER>*> is linked in for clarity,
+# We in plugin mainly access this PAGE property, <*<HEADER>*> is linked in for clarity,
# and/or if want to change from keeping the original \<\<HEADER<TREE>...\>\> above.
#
<<PAGE<TREE>
Title: Index Page
OnLoad : onIndexBodyLoad()
-<div<
+<div<
id:menu_page
<#<
<span class="menu_head">
<span class="ui-icon ui-icon-arrowthick-1-n" style="float:none;"></span></a>
</span>
<hr>
- <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="index.cgi">Index</a><hr>
<a class="ui-button ui-corner-all ui-widget" href="main.cgi">Life Log</a>
->#>
+>#>
>div>
<div<
id:container
<div<
- id:header
+ id:header
<*<PAGE_HEAD>*>
<a<
name: top
<div<
id:content
<*<PAGE_CONTENT>*>
- >div>
+ >div>
<div<
- id:doc_display
+ id:doc_display
class:md_doc
<*<INFO_MD>*>
- >div>
- >div>
+ >div>
+ >div>
<div<
id:footer
<*<PAGE_FOOT>*>
<span<⌋↑>span>
<a<
- id:code
- href:#top
+ id:code
+ href:#top
title:Go to top of page.
<#<To Top Of Page>#>
>a>
<span<⌈>span>
<a<
name: bottom
- >a>
+ >a>
>div>
>div>
<!<Page brought to you by HTMLIndexProcessorPlugin, from the PerlCNF project.>!>
>>PAGE>TREE>
+
<<INFO_MD<ESCAPED>
+**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/)
+<center>Page brought to you by HTMLIndexProcessorPlugin v.<*<HTMLIndexProcessorPlugin::VERSION>*> in Moon Stage (beta).</center>
+
>>
<<CNF_TO_HTML<PLUGIN>
my $msg = shift;
print "<html><body><h2>LifeLog Server Error</h2>";
print "<pre>@[$ENV{PWD}].Error: $msg</pre></body></html>";
-
+
}
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);
my $LOGOUT_RELOGIN_TXT='No, no, NO! Log me In Again.';
my $LOGOUT_IFRAME_ENABLED = 0;
my $LOGOUT_IFRAME = qq|
- <iframe width="60%" height="600px" src="https://www.youtube.com/embed/qTFojoffE78?autoplay=1" frameborder="0" allow="accelerometer;
+ <iframe width="60%" height="600px" src="https://www.youtube.com/embed/qTFojoffE78?autoplay=1" frameborder="0" allow="accelerometer;
autoplay; encrypted-media; gyroscope; picture-in-picture" allowfullscreen>
</iframe>|;
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(
$hst = `hostname` . "($ht[0])" if (@ht);
$frm = <<HTML;
- <form id="frm_login" action="login_ctr.cgi" method="post">
- <table border="0" width="50%"
+ <form id="frm_login" action="login_ctr.cgi" method="post" style="filter: drop-shadow(10px 8px 5px #3e6f70);">
+ <table border="0" width="50%"
style="opacity: 1; box-sizing: border-box; margin-bottom: 5px; box-shadow: 5px 5px 5px $colSHDW;">
<tr class="r0">
<td colspan="3"><h23 id="lifelog_head">Welcome to Life Log</h3></td>
<tr class="r0"><td colspan="2">Host -> <b>$hst</b></td><td><input type="submit" value="Login"/></td></tr>
</table></form>
HTML
- print qq(<br><br><div id ="menu_page" ><span class="menu_head">Menu</span><hr> <a class="ui-button ui-corner-all ui-widget" href="index.cgi">Index</a></div>
+ print qq(
+ <br>
+ <div id="menu_page" style="margin-left: 85vw;"><span class="menu_head">Menu</span><hr>
+ <a class="ui-button ui-corner-all ui-widget" href="index.cgi">Index</a>
+ </div>
<div class="rz login">
$frm
<br>
- <a href="https://github.com/wbudic/LifeLog" target="_blank" style="font-size:small">
+ <a href="https://github.com/wbudic/LifeLog" target="_blank" style="font-size:small">
<div style="display: inline-block; vertical-align: middle; text-align: center; width:50%; opacity: 0.8;">
- <div style="display:table-cell; height:20px; vertical-align: middle;">
- <img src="wsrc/images/pingy.svg" height="30px"> LifeLog v.).Settings::release().qq(</a>
- </div>
+
<div style="display:table-cell; height:20px; vertical-align: middle;">
+ <img src="wsrc/images/pingy.svg" height="30px" style="filter: drop-shadow(10px 10px 5px #3e6f70);"> LifeLog v.).Settings::release().qq(</a>
+ </div>
</div>
-
<br>
</div>
);
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,
"<hr><font color=red><b>SERVER ERROR</b></font> on $now".
"<pre>".$pwd."/$0 -> [\n$err]","\n$dbg</pre>",
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){
$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");
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}
$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);
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 {
}
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);
));
$db->do(qq(
CREATE DATABASE $alias
- WITH
+ WITH
OWNER = $alias
ENCODING = 'UTF8'
LC_COLLATE = 'en_AU.UTF-8'
));
$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){
#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'};
}
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);
$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.
$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){
}
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.
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) {
$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");
}
$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";
}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());
$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;
$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);
#
#
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);
#
#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);
$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);
}
@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]){
# }
#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);
-
+
}
if($token eq '=' || $token eq '=\''){
$grp = $prev; next;
}
- elsif($token=~ /[^!=<>\n]+=$/){
+ elsif($token=~ /[^!=<>\n]+=$/){
$grp = $token =~ s/=$//g; next;
}
elsif($grp){
push @ret, $grp; $grp = "";
}
else{
- $grp .= ' '.$token;
+ $grp .= ' '.$token;
if($token =~ m/'$/){
$grp .=')';
if($reserved{$prev}){push @ret, $prev}
$resolve = $token =~ s/^'//g;
if($resolve =~ m/'$/){
$token = $resolve =~ s/'$//g; $resolve ="";
- }else{next}
+ }else{next}
}
elsif($token =~ m/'$/ and $resolve){
$token =~ s/^$//g;
my $insCat = $db->prepare('INSERT INTO CAT VALUES (?,?,?)');
$db->begin_work();
foreach my $line (@lines) {
-
+
last if ($line =~ /<MIG<>/);#Not doing it with CNF1.0
if( index( $line, '<<CONFIG<' ) == 0 ) {$tt = 0; $inData = 0;}
elsif( index( $line, '<<CAT<' ) == 0 ) {$tt = 1; $inData = 0;}
elsif( index( $line, '<<LOG<' ) == 0 ) {$tt = 2; $inData = 0;}
next if($line=~m/^>>/);
-
+
my @tick = split("`",$line);
if( scalar @tick == 2 ) {
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{
$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;
}
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);
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->{'@'}){
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;
}
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;
}
# 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 };
}
}
+###
+# 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);
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}){
use CGI;
use CGI::Session '-ip_match';
+use constant VERSION => '1.0';
+
our $TAB = ' 'x4;
sub new ($class, $fields={Language=>'English',DateFormat=>'US'}){
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'){
###
-# 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
use Date::Manip;
##no critic ControlStructures::ProhibitMutatingListFunctions
+use constant VERSION => '1.0';
+
our $TAB = ' 'x4;
our $PARSER;
###
};
-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'
$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/\\>/>/gs;
#$script =~ s/\n/<br>/gs;
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);
}}
# @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) = @_;
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"
}
}
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}."</$it>\n";
+ $ret .= "<$it>".$item->{item}."</$it>\n";
}
}
- if($hasItems){
+ if($hasItems){
$ret .= "</$t>\n";
$ret .= "</li>\n" if !$isRootItem;
}
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';
}
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</$code_tag[1]>\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</$code_tag[1]>$post\n);
+ if(!$pret && !$post){
+ $buff .= $ln; next;
+ }
+ }
+ elsif($ln =~ /^\s*```(\w*)(.*)/){
+ my $bfCode; my $pretext = $2; $pretext ="" if !$2; $pretext .= "<br>" 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 .= "</$tag>"; undef $para;
$code = 0; undef $tag;
- if($list_item){
+ if($list_item){
$list_item -> {item} = $list_item -> {item} . $bfCode.'<br>';
$list_item = $list_item -> parent();
next;
}
}else{
- $bfCode .= "<$tag class='$class'>";
+ $bfCode .= "<$tag class='$class'>";
if($class eq 'perl'){
$bfCode .= qq(<h1><span>Perl</span></h1>);
$code = 2;
}else{
if($class eq 'cnf' or $class eq 'html'){
- $bfCode .= '<h1><span class="cnf"><a title="M.C. Hammer -- Can\'t touch this!" href="/" style="text-decoration: none;">'.uc($class).'</a></span></h1>'
+ $bfCode .= "<h1><span class='cnf'>
+ <a title='M.C. Hammer -- Can\'t touch this!' href='/' style='text-decoration: none;'>".uc($class).
+ q(</a></span></h1>).$pretext
}
$code = 1
}
}
- if($list_item){
+ if($list_item){
my $new = HTMLListItem->new('dt', "<br>$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</$h><a name=").scalar(@titels)."\"></a>\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);
$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);
$bqte_nested--;
}
if($ln !~ /(.+)/gm){
- $bqte .= "\n</$bqte_tag><p>\n"
+ $bqte .= "\n</$bqte_tag><p>\n"
}else{
if($bqte_tag eq 'p'){
$ln =~ s/^\s*//g;
$bqte .= ${style($ln)}."</br>";
}else{
- $ln =~ s/^\s*[-+*]\s*|^\s*\d+\.\s*//g;
- $bqte .= "<li>".${style($ln)}."</li>\n";
+ $ln =~ s/^\s*[-+*]\s*|^\s*\d+\.\s*//g;
+ $bqte .= "<li>".${style($ln)}."</li>\n";
}
- }
+ }
}
elsif(!$code && $ln =~ /^\s*\*\*\*/){
if($para){
if($tag eq 'pre' && $code == 1){
$v =~ s/</</g;
$v =~ s/>/>/g;
- $para .= "$v\n";
+ $para .= "$v\n";
}elsif($code == 2){
if($ln =~/^\s*\<+.*>+$/){
- $para .= inlineCNF($v,$spc)."<br>\n"
+ $para .= inlineCNF($v,$spc)."<br>\n"
}else{
$para .= code2HTML($v)."<br>\n"
}
- }else{
+ }else{
$v = inlineCNF($v,$spc);
if(length($v) > length($ln)){
$para .= qq($v<br>);
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/</</g;
+ my $t = $1;
+ my $i = $2;
+ $t =~ s/</</g;
$para .= "<span ".C_B.">$t</span><span ".C_PI.">$i</span><br>";
$pml_val = 1;
- next;
+ next;
}elsif($3){
- my $t = $3;
- $t =~ s/>/>/g;
+ my $t = $3;
+ $t =~ s/>/>/g;
$para .= "<span C_B>$t</span><br>\n";
$pml_val = 0;
next;
}elsif($4&&$5&&6){
- my $t = $4;
+ my $t = $4;
my $v = $5;
my $i = $6;
$t =~ s/</</g;
$pml_val = 1;
next;
}
-
+
$v =~ m/ ^(<<) ([@%]<) ([\$@%]?\w+) ([<>])
- |^(<{2,3})
+ |^(<{2,3})
([\$@%\w]+)\s*
<*([^>]+)
(>{2,3})$
-
+
/gx;# and my @captured = @{^CAPTURE};
-
+
if($5&&$6&&$7&&$8){
my $t = $5;
my $v = $6;
my $c = $8;
$t =~ s/</</g;
$c =~ s/>/>/g;
- $pml_val = 1;
+ $pml_val = 1;
$para .= "<span".C_B.">$t</span><span ".C_PV.">$v</span><span C_B><</span><span class='pi'>$i</span><span ".C_B.">$c</span><br>";
-
+
}elsif($5&&$6){
my $t = $5;
my $i = $6;
$t =~ s/</</g; $pml_val = 1;
$para .= "<span ".C_B.">$t</span><span class='pi'>$i</span><br>";
- }elsif($1 && $2 && $3){
+ }elsif($1 && $2 && $3){
$pml_val = 1;
- $para .= "<span ".C_B."><<$2<\/span><span ".C_PV.">$3</span><span ".C_B.">></span><br>";
+ $para .= "<span ".C_B."><<$2<\/span><span ".C_PV.">$3</span><span ".C_B.">></span><br>";
}elsif($8){
- my $t = $8;
+ my $t = $8;
$t =~ s/>/>/g; $pml_val = 0;
$para .= "<span ".C_B.">$t</span><br>\n";
}
$para .= "$v<br>\n";
}
}
- }
+ }
}else{
if($bqte){
while($bqte_nested-->0){$bqte .="</$bqte_tag></blockqoute>\n"}
$para .= $bqte;
undef $bqte;
}
- $para .= ${style($2)}."\n"
+ $para .= ${style($2)}."\n"
}
}else{
if($list_root && ++$list_end>1){
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(<p>$para</p><br>\n);
}
if($bqte){
while($bqte_nested-->0){$bqte .="\n</$bqte_tag></blockquote>\n"}
- $buff .= $bqte;
- }
+ $buff .= $bqte;
+ }
if($list_root){
- $buff .= $list_root-> toString();
+ $buff .= $list_root-> toString();
}
- $buff .= qq(<p>$para</p>\n) if $para;
+ $buff .= qq(<p>$para</p>\n) if $para;
return [\$buff,\@titels]
}catch($e){
}}
sub code2HTML($val){
- my $v=$val;
+ my ($v,$cmnt)=($val,"");
+
+ $v =~ s/(.*?)(\#.*)/<span class='cmnt'>$2<\/span>/g;
+ if($1 && $2 && $1!~ m/\s+/){
+ $v = $1; $cmnt = "<span class='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/([,;=\-\+]+)/<span class='opr'>$1<\/span>/gx;
- $v =~ s/(my|our|local|do|use|lib|require|new|while|for|foreach|while|if|else|elsif|eval)/<span class='kw'>$1<\/span>/g;
+ $v =~ s/(my|our|local|do|use|lib|require|new|while|for|foreach|while|if|else|elsif|eval)/<span class='kw'>$1<\/span>/g;
$v =~ s/(\$\w+)/<span class='var'>$1<\/span>/g;
$v =~ s/([\(\)\{\}\[\]] | ->)/<span class='bra'>$1<\/span>/gx;
+
foreach(0..$#strs){
- my $w = $strs[$_];
+ my $w = $strs[$_];
$w =~ s/(^['"])(.*)(['"]$)/<span class='Q'>$1<\/span><span class='str'>$2<\/span><span class='Q'>$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<span ".C_PV.">[#[</span>"
}elsif($v=~m/^>{1}(\w*)>{1}/ && $1){
return "$spc<span ".C_B.">></span><span ".C_PV.">$1</span><span ".C_B.">></span>"
}elsif($v=~m/^<\*<.*>\*>$/){
- my $r = "<span ".C_B.">></span><span ".C_PV.">*</span><span ".C_B.">></span>";
+ my $r = "<span ".C_B.">></span><span ".C_PV.">*</span><span ".C_B.">></span>";
$body=~s/>\*>$/$r/;
- $r = "<span ".C_B."><</span><span ".C_PV.">*</span><span ".C_B."><</span>";
+ $r = "<span ".C_B."><</span><span ".C_PV.">*</span><span ".C_B."><</span>";
$body=~s/^<\*</$r/;
return $spc.$body
}
elsif($v eq '>>'){
return "$spc<span ".C_B.">>></span>\n" }
else{
- $v=~/(>+)$/;if($1){
- $cc=$1;
- #$body =~ s/>/>/g;
+ $v=~/(>+\s*)$/;if($1){
+ $v = $1; $v =~ s/>/>/g;
+ return "$spc<span ".C_B.">$v</span>"
}else{
$oo =~ s/</</g;
- if($v=~m/<<<(.*)/){
- return "<span ".C_B.">$oo</span><span ".C_PI.">$1</span>"
- }elsif($v=~m/^(<{2,3})(.*?)([><])(.*)/){
- return "$spc<span ".C_B.">$oo</span><span ".C_PN.">$1</span>><span ".C_B.">$2</span><span ".C_PI.">$3</span>";
+ if($v=~m/>>>/){
+ $v =~ s/>/>/g; return "<span ".C_B.">$v</span>"
+ }elsif($v=~m/<<<(.*)/){
+ return "$spc<span ".C_B.">$oo</span><span ".C_PI.">$1</span>"
+ }elsif($v=~m/^(<{2,3})(.*?)([><])(.*)/){
+ if($4){
+ if($PARSER -> isReservedWord($4)){
+ $v = "<span ".C_PI.">$4</span>"
+ }else{
+ if (!$2){$v = "<span ".C_PA.">$4</span>"}else{$v=""}
+ }
+ my $t = "$1$2$3";
+ my $r = $4;
+ if($2 =~ /[@%]/){
+ if($r =~ /(.*)([><])(.*)/){
+ $v = "$spc<span ".C_B.">$t</span><span ".C_PA.">$1</span>";
+ $v .= "<span ".C_B.">$2</span>";
+ $v .= "<span ".C_PV.">$3</span>";
+ return $v;
+ }
+ }else{
+ $v = "$spc<span ".C_B.">$oo</span><span ".C_PN.">$2</span><span ".C_B.">$3</span>$v";
+ if($r =~ /(\w*)\s(.*)/){
+ return "$v<span ".C_PI.">$1</span> <span ".C_PV.">$2</span>$cc"
+ }else{
+ return $v
+ }
+ }
+ }else{
+ $v = "<span ".C_B.">$3</span>" if $3;
+ }
+ return "$spc<span ".C_B.">$oo</span><span ".C_PN.">$2</span><span ".C_B.">$3</span>$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;
+ $oo =~ s/>/>/g;
+ $cc =~ s/</</g;
+ $cc =~ s/>/>/g;
+ $body =~ s/</</g;
+ $body =~ s/>/>/g;
+ return "$spc<span ".C_B.">$oo</span><span ".C_PV.">$body</span>><span ".C_B.">$cc</span>";
+ }
+
+}else{
$oo =~ s/</</g;
- $cc =~ 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;
$v = "<span ".C_B.">$oo</span>$prop</span><span ".C_B.">$cc</span>";
}
- 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 = "<span ".C_PI.">$i</span>"
- }else{
+ }else{
$i = "<span ".C_PA.">$i</span>"
- }
- my $prop = propValCNF($2);
+ }
+ my $prop = propValCNF($2.$3);
$v = "<span ".C_B.">$oo</span>$i</span>$prop<span ".C_B.">$cc</span>"
}else{
- my $i = $6;
- my $c = $7; $c = $8 if !$c;
- $t =~ s/</</g;
+ my $i = $7;
+ my $c = $8; $c = $9 if !$c;
+ $t =~ s/</</g;
$c =~ s/>/>/g if $c;
- $v = "<span C_B>$t</span><span ".C_PI.">$i</span>$c";
+ $v = "<span C_B>$t</span><span ".C_PI.">$i</span>$c"
}
- }
+ }
elsif($1 && $2 && $3){
+ my $mrk = $1; $mrk ="" if !$mrk;
my $ins = $2;
my $prop = propValCNF($3);
- $v = "<span ".C_B.">$oo</span>$ins<\/span>$prop<span ".C_B.">$cc</span>"
+ $prop .= propValCNF($4) if $4;
+ $v = "<span ".C_B.">$oo$mrk</span><span ".C_PI.">$ins</span>$prop<span ".C_B.">$cc</span>"
+ }elsif($1 && $3 && $4){
+ $body = $4;
+ $oo .= "$1$3";
+ $oo =~ s/</</g;
+ $body =~ /(.*)([><])(.*)/;
+ if($1 && $2 && $3){
+ $v = "<span ".C_B.">$oo</span><span ".C_PI.">$1</span><span ".C_B.">$2</span><span ".C_PV.">$3</span><span ".C_B.">$cc</span>"
+ }else{
+ $v = "<span ".C_B.">$oo</span><span ".C_PI.">$body</span><span ".C_B.">$cc</span>"
+ }
}
return $spc.$v.$restIfAny
}
-sub propValCNF($v){
- $v =~ m/(.*)([=:])(.*)/gs;
- if($1&&$2&&$3){
- return " <span ".C_PN.">$1</span><span class='O'>$2</span><span ".C_PV.">$3</span>";
+sub propValCNF($v){
+ my @match = ($v =~ m/(.*)([=:])(.*)/gs);
+ if(@match){
+ return " <span ".C_PN.">$1</span><span class='O'>$2</span><span ".C_PV.">$3</span>"
+ }
+ elsif($v =~ /[><]/){
+ return "<span ".C_B.">$v</span>"
}else{
- return " <span ".C_PV.">$v</span>";
+ return "<span ".C_PV.">$v</span>"
}
return $v;
}
#Links <https://duckduckgo.com>
$script =~ s/<(http[:\/\w.]*)>/<a href=\"$1\">$1<\/a>/g;
$script =~ s/(\*\*([^\*]*)\*\*)/\<em\>$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/(\*([^\*]*)\*)/\<strong\>$2<\/strong\>/gs;
$script =~ s/__(.*)__/\<del\>$1<\/del\>/gs;
$script =~ s/~~(.*)~~/\<strike\>$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/```(.*)```/\<span\>$v<\/span\>/;
+ $ret =~ s/```(.*)```/\<span\>$v<\/span\>/;
}
-
#Images
$ret =~ s/!\[(.*)\]\((.*)\)/\<div class="div_img"><img class="md_img" src=\"$2\"\ alt=\"$1\"\/><\/div>/;
#Links [Duck Duck Go](https://duckduckgo.com)
.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;
}
/;
perl -MCPAN -e 'install Log::Log4perl'
perl -MCPAN -e 'install Number::Bytes::Human'
perl -MCPAN -e 'install File::ReadBackwards'
+
lifelog.hopto.org / LifeLog.git / commitdiff