# W2H_1.pm 15feb20waw package W2H_1; use 5.010; # need regex extensions use strict; use warnings; # use Data::Dump qw(pp dd); # for debug use constant DEBUG => 0; use constant { DBPR_rx => 0 && DEBUG, }; my %w2h_map = qw(* b / i _ u); # wiki markup -> HTML tag mapping my $mq_wiki_mark = quotemeta join '', keys %w2h_map; # meta-quoted wiki my $rx_wml = qr{ ((?&PRE_OPEN) (?&WIKI_MARK)) # $1: opening wikimark ((?: (?: (?: (?! \g-2 (?&POST_CLOSE)) .)*+) | (?R) )*) # $2: marked body \g-2 (?&POST_CLOSE) # closing wikimark (?(DEFINE) (? (?\s$mq_wiki_mark])) # after string start, > or \s or wml (? (?! [^<\s$mq_wiki_mark])) # before string end, < or \s or wml (? [\Q$mq_wiki_mark\E]) ) }xms; DBPR_rx and print $rx_wml, "\n"; # only used for development diagnostics my $rx_pre_open = qr{ (?]) }xms; my $rx_post_close = qr{ (?! [^\s<]) }xms; my $rx_wiki_mark = qr{ [$mq_wiki_mark] }xms; # only used for development diagnostics die q{bad '\A wm' match} unless '_' =~ m{ $rx_pre_open $rx_wiki_mark }xms; die q{bad '\s wm' match} unless ' _' =~ m{ $rx_pre_open $rx_wiki_mark }xms; die q{bad '> wm' match} unless '>_' =~ m{ $rx_pre_open $rx_wiki_mark }xms; die q{bad 'wm \z' match} unless '_' =~ m{ $rx_wiki_mark $rx_post_close }xms; die q{bad 'wm \s' match} unless '_ ' =~ m{ $rx_wiki_mark $rx_post_close }xms; die q{bad 'wm <' match} unless '_<' =~ m{ $rx_wiki_mark $rx_post_close }xms; # subroutines ###################################################### sub w2h { # not exported; invoke fully-qualified my ($wiki, # string possibly containing wiki markup ) = @_; (my $html = $wiki) =~ s{ $rx_wml # captures to $1 $2 } { my ($html_tag, $body) = ($w2h_map{$1}, w2h($2)); "<$html_tag>$body"; }xmsge; return $html; } 1; #### # W2H_2.pm 15feb20waw package W2H_2; use 5.010; # need regex extensions use strict; use warnings; # use Data::Dump qw(pp dd); # for debug use constant DEBUG => 0; use constant { DBPR_rx => 0 && DEBUG, }; my %w2h_map = qw(* b / i _ u); # wiki markup -> HTML tag mapping my $mq_wiki_mark = quotemeta join '', keys %w2h_map; # meta-quoted wiki my $rx_pre_open = qr{ (?\s$mq_wiki_mark]) }xms; my $rx_post_close = qr{ (?! [^<\s$mq_wiki_mark]) }xms; my $rx_wiki_mark = qr{ [$mq_wiki_mark] }xms; my $rx_wml = qr{ ($rx_pre_open $rx_wiki_mark) # $1: opening wikimark ((?: (?: (?: (?! \g-2 $rx_post_close) .)*+) | (?R) )*) # $2: marked body \g-2 $rx_post_close # closing wikimark }xms; DBPR_rx and print $rx_wml, "\n"; # only used for development diagnostics die q{bad '\A wm' match} unless '_' =~ m{ $rx_pre_open $rx_wiki_mark }xms; die q{bad '\s wm' match} unless ' _' =~ m{ $rx_pre_open $rx_wiki_mark }xms; die q{bad '> wm' match} unless '>_' =~ m{ $rx_pre_open $rx_wiki_mark }xms; die q{bad 'wm \z' match} unless '_' =~ m{ $rx_wiki_mark $rx_post_close }xms; die q{bad 'wm \s' match} unless '_ ' =~ m{ $rx_wiki_mark $rx_post_close }xms; die q{bad 'wm <' match} unless '_<' =~ m{ $rx_wiki_mark $rx_post_close }xms; # subroutines ###################################################### sub w2h { # not exported; invoke fully-qualified my ($wiki, # string possibly containing wiki markup ) = @_; (my $html = $wiki) =~ s{ $rx_wml # captures to $1 $2 } { my ($html_tag, $body) = ($w2h_map{$1}, w2h($2)); "<$html_tag>$body"; }xmsge; return $html; } 1; #### # W2H.t 15feb20waw use strict; use warnings; # use Data::Dump qw(pp dd); # for debug use Test::More 'no_plan'; use Test::NoWarnings; BEGIN { use_ok 'W2H_1'; use_ok 'W2H_2'; } use constant DEBUG => 1; use constant { DBPR_m_d1 => 0 && DEBUG, }; my @Tests = ( [ '_abcd_' => 'abcd', ], [ '_/abcd/_' => 'abcd', ], [ '*_/abcd/_*' => 'abcd', ], [ '*_/a*b_c/d/_*' => 'a*b_c/d', ], [ ' *_/a*b_c/d/_* ' => ' a*b_c/d ', ], [ '_abc__def_' => 'abcdef', ], [ '_abc__def_*ghi**jkl*/mno//pqr/' => 'abcdefghijklmnopqr', ], [ ' _abc__def_*ghi**jkl*/mno//pqr/ ' => ' abcdefghijklmnopqr ', ], [ '_abc_ _def_ *ghi* *jkl* /mno/ /pqr/' => 'abc def ghi jkl mno pqr', ], [ '_abc_ /def/' => 'abc def', ], [ ' _abc_ /def/ ' => ' abc def ', ], [ 'x _abc_ /def/ x' => 'x abc def x', ], [ '_abc /xyz/ cba_ /def/' => 'abc xyz cba def', ], [ '_/one *t/w*o*/ th/r_ee_ null' => 'one t/w*o th/r_ee null', ], [ '_/one *two*/ th/ree_ null _/f*ur *five*/ six_ null _/se_ven *eight*/ nine_ *fail_', => 'one two th/ree null f*ur five six null se_ven eight nine *fail_', 'from pm#11112991' ], ); # testing, testing... FUNT: for my $func_name ( 'W2H_1::w2h', 'W2H_2::w2h', ) { note "\n=== testing $func_name() ===\n\n"; *w2h = do { no strict 'refs'; *$func_name; }; VECTOR: for my $ar_vector (@Tests) { if (not ref $ar_vector) { note $ar_vector; next VECTOR; } my ($wiki, $expected, $comment) = @$ar_vector; $comment = defined $comment ? "$comment: " : ''; my $got = w2h($wiki); DBPR_m_d1 and diag ":$wiki:"; DBPR_m_d1 and diag ":$got:"; is $got, $expected, "${comment}'$wiki' -> '$expected'"; } # end for VECTOR } # end for FUNT done_testing; exit; # subroutines ###################################################### # none for now