From: Will Budic Date: Sun, 7 May 2023 04:06:48 +0000 (+1000) Subject: PerlCNF v.2.8 work start. X-Git-Url: https://lifelog.hopto.org/gitweb/?a=commitdiff_plain;h=684162d10f3db1fcdfe22e15f7bbd0adeebfa62f;p=LifeLog.git PerlCNF v.2.8 work start. --- diff --git a/htdocs/cgi-bin/system/modules/CNFNode.pm b/htdocs/cgi-bin/system/modules/CNFNode.pm new file mode 100644 index 0000000..f24cbd0 --- /dev/null +++ b/htdocs/cgi-bin/system/modules/CNFNode.pm @@ -0,0 +1,469 @@ +# +# 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 diff --git a/htdocs/cgi-bin/system/modules/CNFParser.pm b/htdocs/cgi-bin/system/modules/CNFParser.pm index d795a58..a9f1eea 100644 --- a/htdocs/cgi-bin/system/modules/CNFParser.pm +++ b/htdocs/cgi-bin/system/modules/CNFParser.pm @@ -15,18 +15,19 @@ use Hash::Util qw(lock_hash unlock_hash); 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! ### @@ -87,6 +88,7 @@ sub import { return 1; } + ### # Post parsing instructed special item objects. ## @@ -94,12 +96,14 @@ package InstructedDataItem { 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 { @@ -134,6 +138,11 @@ package PropertyValueStyle { } bless $self, $class } + sub setPlugin{ + my ($self, $obj) = @_; + $self->{plugin} = $obj; + } + sub result { my ($self, $value) = @_; $self->{value} = $value; @@ -512,7 +521,7 @@ sub parse { my ($self, $cnf, $content, $del_keys) = @_; 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 @@ -737,40 +746,47 @@ sub parse { my ($self, $cnf, $content, $del_keys) = @_; $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); } } } @@ -804,6 +820,20 @@ sub parse { my ($self, $cnf, $content, $del_keys) = @_; } # +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. @@ -870,7 +900,7 @@ sub registerInstructor { # 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); @@ -887,8 +917,9 @@ sub doPlugin{ }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!" @@ -896,7 +927,7 @@ sub doPlugin{ } 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') } } diff --git a/htdocs/cgi-bin/system/modules/MarkdownPlugin.pm b/htdocs/cgi-bin/system/modules/MarkdownPlugin.pm new file mode 100644 index 0000000..46cf16e --- /dev/null +++ b/htdocs/cgi-bin/system/modules/MarkdownPlugin.pm @@ -0,0 +1,234 @@ +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 .= ""; $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\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+\\n) + }else{ + $buffer .= qq(
\n) + } + } + elsif($ln =~ /^\s*(.*)/ && length($1)>0){ + if($code){ + my $v=$1; + if($tag eq 'pre'){ + $v =~ s//>/g; + $para .= "$v\n"; + }else{ + $v =~ s/<<(\w+)(<)/<<<\/span>$1<\/span><<\/span>/g; + $v =~ s/>>/>><\/span>/g; + $para .= "$v
\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(

$para


\n); + } + $para="" + }else{ + #$buffer .= qq(
\n); + } + } + } + $buffer .= createList(0,$ltype,\@list) if(@list); + $buffer .= qq(

$para

\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\n) if($r) + }else{ + $li =~ s/^(\d)\|//; + if($1 == 2){ + $bf .= "$tabs
$li
\n" + }else{ + $bf .= "$tabs
  • $li
    • \n" + } + } + } + $bf .= qq($tabs\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 + $script =~ s/<(http[:\/\w.]*)>/$1<\/a>/g; + + my @result = map { + s/\*\*(.*)\*\*/\$1<\/em\>/; + s/\*(.*)\*/\$1<\/strong\>/; + s/__(.*)__/\$1<\/del\>/; + s/~~(.*)~~/\$1<\/strike\>/; + $_ + } split(/\s/,$script); + + my $ret = join(' ',@result); + #Images + $ret =~ s/!\[(.*)\]\((.*)\)/\$1\<\/img\>/; + #Links [Duck Duck Go](https://duckduckgo.com) + $ret =~ s/\[(.*)\]\((.*)\)/\$1\<\/a\>/; + return \$ret; +} + +# + + + + +1; \ No newline at end of file