--- /dev/null
+#
+# Represents a tree node CNF object having children and a parent node if it is not the root.
+# Programed by : Will Budic
+# Source Origin : https://github.com/wbudic/PerlCNF.git
+# Open Source License -> https://choosealicense.com/licenses/isc/
+#
+package CNFNode;
+use strict;
+use warnings;
+use Carp qw(cluck);
+
+sub new {
+ my ($class,$attrs, $self) = @_;
+ $self = \%$attrs;
+ bless $self, $class;
+}
+sub name {
+ my $self = shift;
+ return $self->{'_'}
+}
+###
+# Convenience method, returns string scalar value dereferenced (a copy) of the property value.
+##
+sub val {
+ my $self = shift;
+ my $ret = $self->{'#'};
+ if(ref($ret) eq 'SCALAR'){
+ $ret = $$ret;
+ }
+ return $ret
+}
+sub parent {
+ my $self = shift;
+ return $self->{'@'}
+}
+
+
+sub attributes {
+ my $self = shift;
+ my @nodes;
+ foreach(sort keys %$self){
+ my $node = $self->{$_};
+ if($_ !~ /@|@\$|#_/){
+ $nodes[@nodes] = [$_, $node]
+ }
+ }
+ return @nodes;
+}
+#
+
+###
+# Search a path for node from a path statement.
+# It will always return an array for even a single subproperty.
+# The reason is several subproperties of the same name can be contained by the parent property.
+# It will return an array of list values with (@@).
+# Or will return an array of its shallow list of child nodes with (@$).
+# Or will return an scalar value of an attribute or an property with (#).
+# NOTICE - 20221222 Future versions might provide also for more complex path statements with regular expressions enabled.
+###
+sub find {
+ my ($self, $path, $ret, $prev, $seekArray)=@_;
+ foreach my $name(split(/\//, $path)){
+ if(ref($self) eq "ARRAY"){
+ if($name eq '#'){
+ if(ref($ret) eq "ARRAY"){
+ next
+ }else{
+ return $prev->val()
+ }
+ }elsif($name =~ /\[(\d+)\]/){
+ $self = $ret = @$ret[$1];
+ next
+
+ }else{
+ #if(@$self == 1){
+ $ret = $prev->{'@$'};
+ # }
+ }
+ }else{
+ if($name eq '@@') {
+ $ret = $self->{'@@'}; $seekArray = 1;
+ next
+ }elsif($name eq '@$') {
+ $ret = $self->{'@$'}; #This will initiate further search in subproperties names.
+ next
+ }elsif($name eq '#'){
+ return $ret->val()
+ }if(ref($ret) eq "CNFNode" && $seekArray){
+ $ret = $ret->{$name};
+ next
+ }else{
+ $ret = $self->{'@$'} if ! $seekArray; #This will initiate further search in subproperties names.
+ }
+ }
+ if($ret){
+ my $found = 0;
+ my @arr;
+ undef $prev;
+ foreach(@$ret){
+ if($seekArray && exists $_->{'@$'}){
+ my $n;
+ foreach (@{$_->{'@$'}}){
+ $n = $_;
+ if ($n->{'_'} eq $name){
+ $arr[@arr] = $n;
+ }
+ }
+ if(@arr>1){
+ $ret = \@arr;
+ }else{
+ $ret = $n;
+ }
+ $found++;
+ }elsif (ref($_) eq "CNFNode" and $_->{'_'} eq $name){
+ if($prev){
+ $arr[@arr] = $_;
+ $self = \@arr;
+ $prev = $_;
+ }else{
+ $arr[@arr] = $_;
+ $prev = $self = $_
+ }
+ if(!$found){
+ $self = $ret = $_
+ }else{
+ $ret = \@arr;
+ }
+ $found=1
+ }
+ }
+ $ret = $self->{$name} if(!$found && $name ne '@$');
+ }else{
+ $ret = $self->{$name} ;
+ }
+ }
+ return $ret;
+}
+#
+sub node {
+ my ($self, $path, $ret)=@_;
+ foreach my $name(split(/\//, $path)){
+ $ret = $self->{'@$'};
+ if($ret){
+ foreach(@$ret){
+ if ($_->{'_'} eq $name){
+ $ret = $_; last
+ }
+ }
+ }
+ }
+ return $ret;
+}
+sub nodes {
+ my $self = shift;
+ my $ret = $self->{'@$'};
+ if($ret){
+ return @$ret;
+ }
+ return ();
+}
+###
+# The parsing guts of the CNFNode, that from raw script, recursively creates and tree of nodes from it.
+###
+sub process {
+
+ my ($self, $parser, $script)=@_;
+ my ($sub, $val, $isArray,$body) = (undef,0,0,"");
+ my ($tag,$sta,$end)=("","","");
+ my @array;
+ my ($opening,$closing,$valing)=(0,0,0);
+
+ if(exists $self->{'_'} && $self->{'_'} eq '#'){
+ $val = $self->{'#'};
+ if($val){
+ $val .= "\n$script";
+ }else{
+ $val = $script;
+ }
+ }else{
+ my @lines = split(/\n/, $script);
+ foreach my $ln(@lines){
+ $ln =~ s/^\s+|\s+$//g;
+ #print $ln, "<-","\n";
+ if(length ($ln)){
+ #print $ln, "\n";
+ if($ln =~ /^([<>\[\]])(.*)([<>\[\]])$/ && $1 eq $3){
+ $sta = $1;
+ $tag = $2;
+ $end = $3;
+ my $isClosing = ($sta =~ /[>\]]/) ? 1 : 0;
+ if($tag =~ /^([#\*\@]+)[\[<](.*)[\]>]\/*[#\*\@]+$/){#<- The \/ can sneak in as included in closing tag.
+ if($1 eq '*'){
+ my $link = $2;
+ my $lval = $parser->anon($2);
+ $lval = $parser->{$2} if !$lval; #Anon is passed as an unknown constance (immutable).
+ if($lval){
+ if($opening){
+ $body .= qq($ln\n);
+ }else{
+ #Is this a child node?
+ if(exists $self->{'@'}){
+ my @nodes;
+ my $prev = $self->{'@$'};
+ if($prev) {
+ @nodes = @$prev;
+ }else{
+ @nodes = ();
+ }
+ $nodes[@nodes] = CNFNode->new({'_'=>$link, '*'=>$lval,'@' => \$self});
+ $self->{'@$'} = \@nodes;
+ }
+ else{
+ #Links scripted in main tree parent are copied main tree attributes.
+ $self->{$link} = $lval
+ }
+ }
+ next
+ }else{
+ if(!$opening){warn "Anon link $link not located with $ln for node ".$self->{'_'}};
+ }
+ }elsif($1 eq '@@'){
+ if($opening==$closing){
+ $array[@array] = $2; $val="";
+ next
+ }
+ }else{
+ $val = $2;
+ }
+ }
+ elsif($tag =~ /^(.*)[\[<]\/*(.*)[\]>](.*)$/ && $1 eq $3){
+ if($opening){
+ $body .= qq($ln\n)
+ }
+ else{
+ my $property = CNFNode->new({'_'=>$1, '#' => $2, '@' => \$self});
+ my @nodes;
+ my $prev = $self->{'@$'};
+ if($prev) {
+ @nodes = @$prev;
+ }else{
+ @nodes = ();
+ }
+ $nodes[@nodes] = $property;
+ $self->{'@$'} = \@nodes;
+ }
+ next
+ }
+ elsif($isClosing){
+ $opening--;
+ $closing++;
+ }
+ else{
+ $opening++;
+ $closing--;
+ }
+
+ if(!$sub){
+ $isArray = $isArray? 0 : 1 if $tag =~ /@@/;
+ $sub = $tag; $body = "";
+ next
+ }elsif($tag eq $sub && $isClosing){
+ if($opening==$closing){
+ if($tag eq '#'){
+ $body =~ s/\s$//;#cut only one last nl if any.
+ if(!$val){
+ $val = $body;
+ }else{
+ $val .= $body
+ }
+ $valing = 0;
+ }else{
+ my $a = $isArray;
+ my $property = CNFNode -> new({'_'=>$sub, '@' => \$self});
+ $property->process($parser, $body);
+ $isArray = $a;
+ if($tag eq '@@'){
+ $array[@array] = $property;
+ if( not exists $property->{'#'} && $body ){
+ $body =~ s/\n$//; $property->{'#'} = $body
+ }
+ }else{
+ my @nodes;
+ my $prev = $self->{'@$'};
+ if($prev) {
+ @nodes = @$prev;
+ }else{
+ @nodes = ();
+ }
+ $nodes[@nodes] = $property;
+ $self->{'@$'} = \@nodes;
+ }
+ undef $sub; $body = $val = "";
+ }
+ next
+ }else{
+ # warn "Tag $sta$tag$sta failed closing -> $body"
+ }
+ }
+ }elsif($tag eq '#'){
+ $valing = 1;
+ }elsif($opening==0 && $isArray){
+ $array[@array] = $ln;
+ # next
+ }elsif($opening==0 && $ln =~ /^([<\[])(.+)([<\[])(.*)([>\]])(.+)([>\]])$/ &&
+ $1 eq $3 && $5 eq $7 ){ #<- tagged in line
+ if($2 eq '#') {
+ if($val){$val = "$val $4"}
+ else{$val = $4}
+ }elsif($2 eq '*'){
+ my $link = $4;
+ my $lval = $parser->anon($4);
+ $lval = $parser->{$4} if !$lval; #Anon is passed as an unknown constance (immutable).
+ if($lval){
+ #Is this a child node?
+ if(exists $self->{'@'}){
+ my @nodes;
+ my $prev = $self->{'@$'};
+ if($prev) {
+ @nodes = @$prev;
+ }else{
+ @nodes = ();
+ }
+ $nodes[@nodes] = CNFNode->new({'_'=>$link, '*'=>$lval, '@' => \$self});
+ $self->{'@$'} = \@nodes;
+ }
+ else{
+ #Links scripted in main tree parent are copied main tree attributes.
+ $self->{$link} = $lval
+ }
+
+ }else{
+ warn "Anon link $link not located with $ln for node ".$self->{'_'} if !$opening;
+ }
+ }elsif($2 eq '@@'){
+ $array[@array] = CNFNode->new({'_'=>$2, '#'=>$4, '@' => \$self});
+ }else{
+ my $property = CNFNode->new({'_'=>$2, '#'=>$4, '@' => \$self});
+ my @nodes;
+ my $prev = $self->{'@$'};
+ if($prev) {
+ @nodes = @$prev;
+ }else{
+ @nodes = ();
+ }
+ $nodes[@nodes] = $property;
+ $self->{'@$'} = \@nodes;
+ }
+
+ next
+ }elsif($val){
+ $val = $self->{'#'};
+ if($val){
+ $self->{'#'} = qq($val\n$ln\n);
+ }else{
+ $self->{'#'} = qq($ln\n);
+ }
+ }
+ elsif($opening < 1){
+ if($ln =~m/^([<\[]@@[<\[])(.*?)([>\]@@[>\]])$/){
+ $array[@array] = $2;
+ next;
+ }
+ my @attr = ($ln =~m/([\s\w]*?)\s*[=:]\s*(.*)\s*/);
+ if(@attr>1){
+ my $n = $attr[0];
+ my $v = $attr[1];
+ $self->{$n} = $v;
+ next;
+ }else{
+ $val = $ln if $val;
+ }
+ }
+ $body .= qq($ln\n)
+ }
+ elsif($tag eq '#'){
+ $body .= qq(\n)
+ }
+ }
+ }
+ $self->{'@@'} = \@array if @array;
+ $self->{'#'} = \$val if $val;
+ return \$self;
+}
+
+sub validate {
+ my ($self, $script) = @_;
+ my ($tag,$sta,$end,$lnc,$errors)=("","","",0,0);
+ my (@opening,@closing,@singels);
+ my ($open,$close) = (0,0);
+ my @lines = split(/\n/, $script);
+ foreach my $ln(@lines){
+ $ln =~ s/^\s+|\s+$//g;
+ $lnc++;
+ #print $ln, "<-","\n";
+ if(length ($ln)){
+ #print $ln, "\n";
+ if($ln =~ /^([<>\[\]])(.*)([<>\[\]])$/ && $1 eq $3){
+ $sta = $1;
+ $tag = $2;
+ $end = $3;
+ my $isClosing = ($sta =~ /[>\]]/) ? 1 : 0;
+ if($tag =~ /^([#\*\@]+)[\[<](.*)[\]>]\/*[#\*\@]+$/){
+
+ }elsif($tag =~ /^(.*)[\[<]\/*(.*)[\]>](.*)$/ && $1 eq $3){
+ $singels[@singels] = $tag;
+ next
+ }
+ elsif($isClosing){
+ $close++;
+ push @closing, {T=>$tag, idx=>$close, L=>$lnc, N=>($open-$close+1),S=>$sta};
+ }
+ else{
+ push @opening, {T=>$tag, idx=>$open, L=>$lnc, N=>($open-$close),S=>$sta};
+ $open++;
+ }
+ }
+ }
+ }
+ if(@opening != @closing){
+ cluck "Opening and clossing tags mismatch!";
+ foreach my $o(@opening){
+ my $c = pop @closing;
+ if(!$c){
+ $errors++;
+ warn "Error unclosed tag-> [".$o->{T}.'[ @'.$o->{L}
+ }
+ }
+
+ }else{
+ my $errors = 0; my $error_tag; my $nesting;
+ my $cnt = $#opening;
+ for my $i (0..$cnt){
+
+ my $o = $opening[$i];
+ my $c = $closing[$cnt - $i];
+ if($o->{T} ne $c->{T}){
+ print '['.$o->{T}."[ idx ".$o->{idx}." line ".$o->{L}.
+ ' but picked for closing: ]'.$c->{T}.'] idx '.$o->{idx}.' line '.$c->{L}."\n" if $self->{DEBUG};
+ # Let's try same index from the clossing array.
+ $c = $closing[$i];
+ }else{next}
+
+ if($o->{T} ne $c->{T}){
+ my $j = $cnt;
+ for ($j = $cnt; $j>-1; $j--){ # TODO 2023-0117 - For now matching by tag name,
+ $c = $closing[$j];# can't be bothered, to check if this will always be appropriate.
+ last if $c -> {T} eq $o->{T}
+ }
+ print "\t search [".$o->{T}.'[ idx '.$o->{idx} .' line '.$o->{L}.
+ ' top found: ]'.$c->{T}."] idx ".$c->{idx}." line ".$c->{N}." loops: $j \n" if $self->{DEBUG};
+ }else{next}
+
+ if($o->{T} ne $c->{T} && $o->{N} ne $c->{N}){
+ cluck "Error opening and clossing tags mismatch for ".
+ brk($o).' ln: '.$o->{L}.' idx: '.$o->{idx}.
+ ' wrongly matched with '.brk($c).' ln: '.$c->{L}.' idx: '.$c->{idx}."\n";
+ $errors++;
+ }
+ }
+ }
+ return $errors;
+}
+
+sub brk{
+ my $t = shift;
+ return 'tag: \''.$t->{S}.$t->{T}.$t->{S}.'\''
+}
+
+1;
\ No newline at end of file
use Time::HiRes qw(time);
use DateTime;
+
# Do not remove the following no critic, no security or object issues possible.
# We can use perls default behaviour on return.
##no critic qw(Subroutines::RequireFinalReturn,ControlStructures::ProhibitMutatingListFunctions);
-use constant VERSION => '2.7';
-
+use constant VERSION => '2.8';
+our $CONSTREQ = 0;
our @files;
our %lists;
our %properties;
our %instructors;
-our $CONSTREQ = 0;
+
###
# Package fields are always global in perl!
###
return 1;
}
+
###
# Post parsing instructed special item objects.
##
our $dataItemCounter = int(0);
- sub new { my ($class, $ele, $ins, $val) = @_;
+ sub new { my ($class, $ele, $ins, $val) = @_;
+ my $priority = ($val =~ s/_HAS_PROCESSING_PRIORITY_//si)?1:0;
bless {
ele => $ele,
aid => $dataItemCounter++,
ins => $ins,
- val => $val
+ val => $val,
+ priority => $priority
}, $class
}
sub toString {
}
bless $self, $class
}
+ sub setPlugin{
+ my ($self, $obj) = @_;
+ $self->{plugin} = $obj;
+ }
+
sub result {
my ($self, $value) = @_;
$self->{value} = $value;
foreach my $p(@props){
if($p && $p eq 'MACRO'){$macro=1}
elsif( $p && length($p)>0 ){
- my @pair = ($p=~/\s*(\w*)\s*[=:]\s*(.*)/s);#split(/\s*=\s*/, $p);
+ my @pair = ($p=~/\s*([-+_\w]*)\s*[=:]\s*(.*)/s);#split(/\s*=\s*/, $p);
next if (@pair != 2 || $pair[0] =~ m/^[#\\\/]+/m);#skip, it is a comment or not '=' delimited line.
my $name = $pair[0];
my $value = $pair[1]; $value =~ s/^\s*["']|['"]$//g;#strip quotes
$ditms[@ditms] = $struct;
}
}
+ my @del;
for my $idx(0..$#ditms) {
my $struct = $ditms[$idx];
- my $type = ref($struct);
- if($type eq 'CNFNode' && $struct->{'script'}=~/_HAS_PROCESSING_PRIORITY_/si){
+ my $type = ref($struct);
+ if($type eq 'CNFNode' && ($struct->{'script'} =~ s/_HAS_PROCESSING_PRIORITY_//si)){ # This will within trim out the flag if found.
$struct->validate($struct->{'script'}) if $self->{ENABLE_WARNINGS};
$anons->{$struct->{'_'}} = $struct->process($self, $struct->{'script'});
- splice @ditms, $idx,1;
+ #splice @ditms, $idx,1; <- causing havoc when key order is scrambled. Weirdest thing in perl!
+ push @del, $idx;
}
}
+ while(@del){
+ splice @ditms,pop @del, 1
+ }
+
for my $idx(0..$#ditms) {
my $struct = $ditms[$idx];
my $type = ref($struct);
if($type eq 'CNFNode'){
$struct->validate($struct->{'script'}) if $self->{ENABLE_WARNINGS};
$anons->{$struct->{'_'}} = $struct->process($self, $struct->{'script'});
- splice @ditms, $idx,1;
+ push @del, $idx;
+ }elsif($type eq 'InstructedDataItem' && $struct->{'priority'}){
+ my $t = $struct->{ins};
+ if($t eq 'PLUGIN'){
+ instructPlugin($self,$struct,$anons);
+ }
+ push @del, $idx;
}
}
- @ditms = sort {$a->{aid} <=> $b->{aid}} @ditms;
+ while(@del){
+ splice @ditms,pop @del, 1
+ }
+
+ @ditms = sort {$a->{aid} <=> $b->{aid}} @ditms if $#ditms > 1;
foreach my $struct(@ditms){
my $type = ref($struct);
if($type eq 'InstructedDataItem'){
my $t = $struct->{ins};
- if($t eq 'PLUGIN'){ #for now we keep the plugin instance.
- try{
- $properties{$struct->{'ele'}} = doPlugin($self, $struct, $anons);
- $self->log("Plugin instructed ->". $struct->{'ele'});
- }catch{
- if($self->{STRICT}){
- CNFParserException->throw(error=>@_,trace=>1);
- }else{
- $self->trace("Error @ Plugin -> ". $struct->toString() ." Error-> $@")
- }
- }
+ if($t eq 'PLUGIN'){
+ instructPlugin($self,$struct,$anons);
}
}
}
}
#
+sub instructPlugin {
+ my ($self, $struct, $anons) = @_;
+ try{
+ $properties{$struct->{'ele'}} = doPlugin($self, $struct, $anons);
+ $self->log("Plugin instructed ->". $struct->{'ele'});
+ }catch($e){
+ if($self->{STRICT}){
+ CNFParserException->throw(error=>$e, show_trace=>1);
+ }else{
+ $self->trace("Error @ Plugin -> ". $struct->toString() ." Error-> $@")
+ }
+ }
+}
+
our $SQL;
sub SQL {
if(!$SQL){##It is late compiled on demand.
# Setup and pass to pluging CNF functionality.
# @TODO Current Under development.
###
-sub doPlugin{
+sub doPlugin {
my ($self, $struct, $anons) = @_;
my ($elem, $script) = ($struct->{'ele'}, $struct->{'val'});
my $plugin = PropertyValueStyle->new($elem, $script);
}else{
$obj = $pck->new();
}
- my $res = $obj->$sub($self,$prp);
- if($res){
+ my $res = $obj->$sub($self, $prp);
+ if($res){
+ $plugin->setPlugin($obj);
return $plugin;
}else{
die "Sorry, the PLUGIN feature has not been Implemented Yet!"
}
else{
die qq(Invalid plugin encountered '$elem' in "). $self->{'CNF_CONTENT'} .qq(
- Plugin must have attributes -> 'library', 'property' and 'subroutine')
+ Plugin must have attributes -> 'package', 'property' and 'subroutine')
}
}
--- /dev/null
+package MarkdownPlugin;
+
+use strict;
+use warnings;
+use Syntax::Keyword::Try;
+use Exception::Class ('MarkdownPluginException');
+use feature qw(signatures);
+use Date::Manip;
+
+our $TAB = ' 'x4;
+
+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");
+ $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{
+ my $script = $parser->anon($property);
+ die "Property not found [$property]!" if !$script;
+ if($script !~ /\n/ and -e $script ){
+ my $file = $parser->anon($property);
+ $script = do {
+ open my $fh, '<:encoding(UTF-8)', $script or MarkdownPluginException->throw("File not avaliable: $script");
+ local $/;
+ <$fh>;
+ };
+ }
+ my @doc = @{parse($self,$script)};
+ $parser->data()->{$property} = $doc[0];
+ $parser->data()->{$property.'_headings'} = $doc[1];
+
+}catch{
+ MarkdownPluginException->throw(error=>$@ ,show_trace=>1);
+}}
+
+
+
+sub parse ($self, $script){
+
+ my ($buffer, $para, $ol, $lnc);
+ my @list; my $ltype=0; my $nix=0;my $nplen=0;
+ my @titels;
+ $script =~ s/^\s*|\s*$//;
+ my $code = 0; my $tag;
+ foreach my $ln(split(/\n/,$script)){
+ $ln =~ s/\t/$TAB/gs;
+ $lnc++;
+ if($ln =~ /^```(\w*)/){
+ my $class = $1;
+ if($1){
+ $tag = $1;
+ $tag = 'div' if($tag eq 'html');
+ $tag = 'div' if($tag eq 'code');
+ }elsif(!$tag){
+ $tag = $class = 'pre';
+ }
+ if($code){
+ if($para){
+ $buffer .= "$para\n"
+ }
+ $buffer .= "</$tag>"; $code =0; $tag = $para = "";
+ }else{
+ $buffer .= "<$tag class='$class'>"; $code = 1;
+ }
+ }elsif(!$code && $ln =~ /^\s*(#+)\s*(.*)/){
+ my $h = 'h'.length($1);
+ my $title = $2;
+ $titels[@titels] = {$lnc,$title};
+ $buffer .= qq(<$h>$title</$h><a name=").scalar(@titels)."\"></a>\n"
+ }
+ elsif(!$code && ($ln =~ /^(\s+)(\d+)\.\s(.*)/ || $ln =~ /^(\s*)([-+*])\s(.*)/)){
+ my @arr;
+ my $spc = length($1);
+ my $val = ${style($3)};
+ $ltype = $2 =~ /[-+*]/ ? 1:0;
+ if($spc>$nplen){
+ $nplen = $spc;
+ $list[@list] = \@arr;
+ $nix++;
+ }elsif($spc<$nplen){
+ $nix--;
+ }
+ if($list[$nix-1]){
+ @arr = @{$list[$nix-1]};
+ $arr[@arr] = $ltype .'|'.$val;
+ $list[$nix-1] = \@arr;
+ }else{
+ $arr[@arr] = $ltype .'|'.$val;
+ $list[@list] = \@arr;
+ }
+ }elsif(!$code && $ln =~ /^\s+\</ ){
+ $ln =~ s/^\s*\<//;
+ $para .= ${style($ln)}." ";
+ }
+ elsif(!$code && $ln =~ /^\s*\*\*\*/){
+ if($para){
+ $para .= qq(<hr>\n)
+ }else{
+ $buffer .= qq(<hr>\n)
+ }
+ }
+ elsif($ln =~ /^\s*(.*)/ && length($1)>0){
+ if($code){
+ my $v=$1;
+ if($tag eq 'pre'){
+ $v =~ s/</</g;
+ $v =~ s/>/>/g;
+ $para .= "$v\n";
+ }else{
+ $v =~ s/<<(\w+)(<)/<span class="bra"><<<\/span><span class="key">$1<\/span><span class="bra"><<\/span>/g;
+ $v =~ s/>>/<span class="bra">>><\/span>/g;
+ $para .= "$v<br>\n";
+ }
+
+ }else{
+ $para .= ${style($1)}."\n"
+ }
+ }else{
+ if(@list){
+ if($para){
+ my @arr;
+ if($list[$nix-1]){
+ @arr = @{$list[$nix-1]};
+ $arr[@arr] = '2|'.$para;
+ $list[$nix-1] = \@arr;
+ }else{
+ $arr[@arr] = '2|'.$para;
+ $list[@list] = \@arr;
+ }
+ $para=""
+ }
+ $buffer .= createList(0,$ltype,\@list);
+ undef @list; $nplen = 0
+ }
+ elsif($para){
+ if($code){
+ $buffer .= $para;
+ }else{
+ $buffer .= qq(<p>$para</p><br>\n);
+ }
+ $para=""
+ }else{
+ #$buffer .= qq(<br>\n);
+ }
+ }
+ }
+ $buffer .= createList(0,$ltype,\@list) if(@list);
+ $buffer .= qq(<p>$para</p>\n) if $para;
+
+return [\$buffer,\@titels]
+}
+
+my @LIST_ITEM_TYPE = ('ol','ul','blockquote');
+
+sub createList ($nested,$type,@list){
+ $nested++;
+ my ($bf,$tabs) =("", " "x$nested);
+ my $tag = $LIST_ITEM_TYPE[$type];
+
+ foreach my $arr(@list){
+ $bf .= qq($tabs<$tag>\n) if $nested>1;
+ foreach my $li(@$arr){
+ if(ref($li) eq 'ARRAY'){
+ $bf =~ s/\s<\/($tag)>\s$//gs if $bf;
+ my $r = $1;
+ my @lst = \@$li;
+ my $typ = get_list_type(@lst);
+ $bf .= createList($nested,$typ,@lst);
+ $bf .= qq($tabs</$tag>\n) if($r)
+ }else{
+ $li =~ s/^(\d)\|//;
+ if($1 == 2){
+ $bf .= "$tabs<blockquote>$li</blockquote>\n"
+ }else{
+ $bf .= "$tabs<li>$li</li>\n"
+ }
+ }
+ }
+ $bf .= qq($tabs</$tag>\n) if $nested>1;
+ }
+ return $bf
+}
+
+sub get_list_type (@list){
+ foreach my $arr(@list){
+ foreach my $li(@$arr){
+ if($li =~ /^(\d)|/){
+ return $1;
+ }
+ last;
+ }
+ }
+ return 0;
+}
+
+sub style ($script){
+ MarkdownPluginException->throw("Invalid argument!") if !$script;
+ #Links <https://duckduckgo.com>
+ $script =~ s/<(http[:\/\w.]*)>/<a href=\"$1\">$1<\/a>/g;
+
+ my @result = map {
+ s/\*\*(.*)\*\*/\<em\>$1<\/em\>/;
+ s/\*(.*)\*/\<strong\>$1<\/strong\>/;
+ s/__(.*)__/\<del\>$1<\/del\>/;
+ s/~~(.*)~~/\<strike\>$1<\/strike\>/;
+ $_
+ } split(/\s/,$script);
+
+ my $ret = join(' ',@result);
+ #Images
+ $ret =~ s/!\[(.*)\]\((.*)\)/\<img class="md_img" src=\"$2\"\>$1\<\/img\>/;
+ #Links [Duck Duck Go](https://duckduckgo.com)
+ $ret =~ s/\[(.*)\]\((.*)\)/\<a href=\"$2\"\>$1\<\/a\>/;
+ return \$ret;
+}
+
+#
+
+
+
+
+1;
\ No newline at end of file
lifelog.hopto.org / LifeLog.git / commitdiff