diff options
author | Max Maischein <corion@corion.net> | 2020-12-18 10:12:49 +0100 |
---|---|---|
committer | Max Maischein <corion@corion.net> | 2020-12-18 10:12:49 +0100 |
commit | 50c2de5ac1a90ceff3b7f893a822818dd20dd63e (patch) | |
tree | d52a4afb873d49d0d71d600098c722a84fc40fec /cpan | |
parent | 1cd5f0d5fa70621757c327e1f6ff04bcb220e0a1 (diff) | |
download | perl-50c2de5ac1a90ceff3b7f893a822818dd20dd63e.tar.gz |
Update Text::Balanced from 2.03 to 2.04
No entry in Perldelta because that will be generated automatically
Diffstat (limited to 'cpan')
-rw-r--r-- | cpan/Text-Balanced/lib/Text/Balanced.pm | 2196 | ||||
-rw-r--r-- | cpan/Text-Balanced/t/01_compile.t | 7 | ||||
-rw-r--r-- | cpan/Text-Balanced/t/02_extbrk.t | 64 | ||||
-rw-r--r-- | cpan/Text-Balanced/t/03_extcbk.t | 66 | ||||
-rw-r--r-- | cpan/Text-Balanced/t/04_extdel.t | 60 | ||||
-rw-r--r-- | cpan/Text-Balanced/t/05_extmul.t | 198 | ||||
-rw-r--r-- | cpan/Text-Balanced/t/06_extqlk.t | 102 | ||||
-rw-r--r-- | cpan/Text-Balanced/t/07_exttag.t | 118 | ||||
-rw-r--r-- | cpan/Text-Balanced/t/08_extvar.t | 62 | ||||
-rw-r--r-- | cpan/Text-Balanced/t/09_gentag.t | 119 | ||||
-rw-r--r-- | cpan/Text-Balanced/t/94_changes.t | 48 | ||||
-rw-r--r-- | cpan/Text-Balanced/t/95_critic.t | 48 | ||||
-rw-r--r-- | cpan/Text-Balanced/t/96_pmv.t | 32 | ||||
-rw-r--r-- | cpan/Text-Balanced/t/97_pod.t | 32 | ||||
-rw-r--r-- | cpan/Text-Balanced/t/98_pod_coverage.t | 51 |
15 files changed, 1791 insertions, 1412 deletions
diff --git a/cpan/Text-Balanced/lib/Text/Balanced.pm b/cpan/Text-Balanced/lib/Text/Balanced.pm index f1a5780a0b..324a023f38 100644 --- a/cpan/Text-Balanced/lib/Text/Balanced.pm +++ b/cpan/Text-Balanced/lib/Text/Balanced.pm @@ -1,35 +1,44 @@ +# Copyright (C) 1997-2001 Damian Conway. All rights reserved. +# Copyright (C) 2009 Adam Kennedy. +# Copyright (C) 2015 Steve Hay. All rights reserved. + +# This module is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU General +# Public License or the Artistic License, as specified in the F<LICENCE> file. + package Text::Balanced; # EXTRACT VARIOUSLY DELIMITED TEXT SEQUENCES FROM STRINGS. # FOR FULL DOCUMENTATION SEE Balanced.pod -use 5.005; +use 5.008001; use strict; use Exporter (); -use SelfLoader; use vars qw { $VERSION @ISA %EXPORT_TAGS }; BEGIN { - $VERSION = '2.03'; - @ISA = 'Exporter'; - %EXPORT_TAGS = ( - ALL => [ qw{ - &extract_delimited - &extract_bracketed - &extract_quotelike - &extract_codeblock - &extract_variable - &extract_tagged - &extract_multiple - &gen_delimited_pat - &gen_extract_tagged - &delimited_pat - } ], - ); + $VERSION = '2.04'; + @ISA = 'Exporter'; + %EXPORT_TAGS = ( + ALL => [ qw{ + &extract_delimited + &extract_bracketed + &extract_quotelike + &extract_codeblock + &extract_variable + &extract_tagged + &extract_multiple + &gen_delimited_pat + &gen_extract_tagged + &delimited_pat + } ], + ); } Exporter::export_ok_tags('ALL'); +## no critic (Subroutines::ProhibitSubroutinePrototypes) + # PROTOTYPES sub _match_bracketed($$$$$$); @@ -40,80 +49,80 @@ sub _match_quotelike($$$$); # HANDLE RETURN VALUES IN VARIOUS CONTEXTS sub _failmsg { - my ($message, $pos) = @_; - $@ = bless { - error => $message, - pos => $pos, - }, 'Text::Balanced::ErrorMsg'; + my ($message, $pos) = @_; + $@ = bless { + error => $message, + pos => $pos, + }, 'Text::Balanced::ErrorMsg'; } sub _fail { - my ($wantarray, $textref, $message, $pos) = @_; - _failmsg $message, $pos if $message; - return (undef, $$textref, undef) if $wantarray; - return undef; + my ($wantarray, $textref, $message, $pos) = @_; + _failmsg $message, $pos if $message; + return (undef, $$textref, undef) if $wantarray; + return; } sub _succeed { - $@ = undef; - my ($wantarray,$textref) = splice @_, 0, 2; - my ($extrapos, $extralen) = @_ > 18 - ? splice(@_, -2, 2) - : (0, 0); - my ($startlen, $oppos) = @_[5,6]; - my $remainderpos = $_[2]; - if ( $wantarray ) { - my @res; - while (my ($from, $len) = splice @_, 0, 2) { - push @res, substr($$textref, $from, $len); - } - if ( $extralen ) { # CORRECT FILLET - my $extra = substr($res[0], $extrapos-$oppos, $extralen, "\n"); - $res[1] = "$extra$res[1]"; - eval { substr($$textref,$remainderpos,0) = $extra; - substr($$textref,$extrapos,$extralen,"\n")} ; - #REARRANGE HERE DOC AND FILLET IF POSSIBLE - pos($$textref) = $remainderpos-$extralen+1; # RESET \G - } else { - pos($$textref) = $remainderpos; # RESET \G - } - return @res; - } else { - my $match = substr($$textref,$_[0],$_[1]); - substr($match,$extrapos-$_[0]-$startlen,$extralen,"") if $extralen; - my $extra = $extralen - ? substr($$textref, $extrapos, $extralen)."\n" : ""; - eval {substr($$textref,$_[4],$_[1]+$_[5])=$extra} ; #CHOP OUT PREFIX & MATCH, IF POSSIBLE - pos($$textref) = $_[4]; # RESET \G - return $match; - } + $@ = undef; + my ($wantarray,$textref) = splice @_, 0, 2; + my ($extrapos, $extralen) = @_ > 18 + ? splice(@_, -2, 2) + : (0, 0); + my ($startlen, $oppos) = @_[5,6]; + my $remainderpos = $_[2]; + if ( $wantarray ) { + my @res; + while (my ($from, $len) = splice @_, 0, 2) { + push @res, substr($$textref, $from, $len); + } + if ( $extralen ) { # CORRECT FILLET + my $extra = substr($res[0], $extrapos-$oppos, $extralen, "\n"); + $res[1] = "$extra$res[1]"; + eval { substr($$textref,$remainderpos,0) = $extra; + substr($$textref,$extrapos,$extralen,"\n")} ; + #REARRANGE HERE DOC AND FILLET IF POSSIBLE + pos($$textref) = $remainderpos-$extralen+1; # RESET \G + } else { + pos($$textref) = $remainderpos; # RESET \G + } + return @res; + } else { + my $match = substr($$textref,$_[0],$_[1]); + substr($match,$extrapos-$_[0]-$startlen,$extralen,"") if $extralen; + my $extra = $extralen + ? substr($$textref, $extrapos, $extralen)."\n" : ""; + eval {substr($$textref,$_[4],$_[1]+$_[5])=$extra} ; #CHOP OUT PREFIX & MATCH, IF POSSIBLE + pos($$textref) = $_[4]; # RESET \G + return $match; + } } # BUILD A PATTERN MATCHING A SIMPLE DELIMITED STRING sub gen_delimited_pat($;$) # ($delimiters;$escapes) { - my ($dels, $escs) = @_; - return "" unless $dels =~ /\S/; - $escs = '\\' unless $escs; - $escs .= substr($escs,-1) x (length($dels)-length($escs)); - my @pat = (); - my $i; - for ($i=0; $i<length $dels; $i++) - { - my $del = quotemeta substr($dels,$i,1); - my $esc = quotemeta substr($escs,$i,1); - if ($del eq $esc) - { - push @pat, "$del(?:[^$del]*(?:(?:$del$del)[^$del]*)*)$del"; - } - else - { - push @pat, "$del(?:[^$esc$del]*(?:$esc.[^$esc$del]*)*)$del"; - } - } - my $pat = join '|', @pat; - return "(?:$pat)"; + my ($dels, $escs) = @_; + return "" unless $dels =~ /\S/; + $escs = '\\' unless $escs; + $escs .= substr($escs,-1) x (length($dels)-length($escs)); + my @pat = (); + my $i; + for ($i=0; $i<length $dels; $i++) + { + my $del = quotemeta substr($dels,$i,1); + my $esc = quotemeta substr($escs,$i,1); + if ($del eq $esc) + { + push @pat, "$del(?:[^$del]*(?:(?:$del$del)[^$del]*)*)$del"; + } + else + { + push @pat, "$del(?:[^$esc$del]*(?:$esc.[^$esc$del]*)*)$del"; + } + } + my $pat = join '|', @pat; + return "(?:$pat)"; } *delimited_pat = \&gen_delimited_pat; @@ -122,315 +131,316 @@ sub gen_delimited_pat($;$) # ($delimiters;$escapes) sub extract_delimited (;$$$$) { - my $textref = defined $_[0] ? \$_[0] : \$_; - my $wantarray = wantarray; - my $del = defined $_[1] ? $_[1] : qq{\'\"\`}; - my $pre = defined $_[2] ? $_[2] : '\s*'; - my $esc = defined $_[3] ? $_[3] : qq{\\}; - my $pat = gen_delimited_pat($del, $esc); - my $startpos = pos $$textref || 0; - return _fail($wantarray, $textref, "Not a delimited pattern", 0) - unless $$textref =~ m/\G($pre)($pat)/gc; - my $prelen = length($1); - my $matchpos = $startpos+$prelen; - my $endpos = pos $$textref; - return _succeed $wantarray, $textref, - $matchpos, $endpos-$matchpos, # MATCH - $endpos, length($$textref)-$endpos, # REMAINDER - $startpos, $prelen; # PREFIX + my $textref = defined $_[0] ? \$_[0] : \$_; + my $wantarray = wantarray; + my $del = defined $_[1] ? $_[1] : qq{\'\"\`}; + my $pre = defined $_[2] ? $_[2] : '\s*'; + my $esc = defined $_[3] ? $_[3] : qq{\\}; + my $pat = gen_delimited_pat($del, $esc); + my $startpos = pos $$textref || 0; + return _fail($wantarray, $textref, "Not a delimited pattern", 0) + unless $$textref =~ m/\G($pre)($pat)/gc; + my $prelen = length($1); + my $matchpos = $startpos+$prelen; + my $endpos = pos $$textref; + return _succeed $wantarray, $textref, + $matchpos, $endpos-$matchpos, # MATCH + $endpos, length($$textref)-$endpos, # REMAINDER + $startpos, $prelen; # PREFIX } sub extract_bracketed (;$$$) { - my $textref = defined $_[0] ? \$_[0] : \$_; - my $ldel = defined $_[1] ? $_[1] : '{([<'; - my $pre = defined $_[2] ? $_[2] : '\s*'; - my $wantarray = wantarray; - my $qdel = ""; - my $quotelike; - $ldel =~ s/'//g and $qdel .= q{'}; - $ldel =~ s/"//g and $qdel .= q{"}; - $ldel =~ s/`//g and $qdel .= q{`}; - $ldel =~ s/q//g and $quotelike = 1; - $ldel =~ tr/[](){}<>\0-\377/[[(({{<</ds; - my $rdel = $ldel; - unless ($rdel =~ tr/[({</])}>/) - { - return _fail $wantarray, $textref, - "Did not find a suitable bracket in delimiter: \"$_[1]\"", - 0; - } - my $posbug = pos; - $ldel = join('|', map { quotemeta $_ } split('', $ldel)); - $rdel = join('|', map { quotemeta $_ } split('', $rdel)); - pos = $posbug; - - my $startpos = pos $$textref || 0; - my @match = _match_bracketed($textref,$pre, $ldel, $qdel, $quotelike, $rdel); - - return _fail ($wantarray, $textref) unless @match; - - return _succeed ( $wantarray, $textref, - $match[2], $match[5]+2, # MATCH - @match[8,9], # REMAINDER - @match[0,1], # PREFIX - ); + my $textref = defined $_[0] ? \$_[0] : \$_; + my $ldel = defined $_[1] ? $_[1] : '{([<'; + my $pre = defined $_[2] ? $_[2] : '\s*'; + my $wantarray = wantarray; + my $qdel = ""; + my $quotelike; + $ldel =~ s/'//g and $qdel .= q{'}; + $ldel =~ s/"//g and $qdel .= q{"}; + $ldel =~ s/`//g and $qdel .= q{`}; + $ldel =~ s/q//g and $quotelike = 1; + $ldel =~ tr/[](){}<>\0-\377/[[(({{<</ds; + my $rdel = $ldel; + unless ($rdel =~ tr/[({</])}>/) + { + return _fail $wantarray, $textref, + "Did not find a suitable bracket in delimiter: \"$_[1]\"", + 0; + } + my $posbug = pos; + $ldel = join('|', map { quotemeta $_ } split('', $ldel)); + $rdel = join('|', map { quotemeta $_ } split('', $rdel)); + pos = $posbug; + + my $startpos = pos $$textref || 0; + my @match = _match_bracketed($textref,$pre, $ldel, $qdel, $quotelike, $rdel); + + return _fail ($wantarray, $textref) unless @match; + + return _succeed ( $wantarray, $textref, + $match[2], $match[5]+2, # MATCH + @match[8,9], # REMAINDER + @match[0,1], # PREFIX + ); } -sub _match_bracketed($$$$$$) # $textref, $pre, $ldel, $qdel, $quotelike, $rdel +sub _match_bracketed($$$$$$) # $textref, $pre, $ldel, $qdel, $quotelike, $rdel { - my ($textref, $pre, $ldel, $qdel, $quotelike, $rdel) = @_; - my ($startpos, $ldelpos, $endpos) = (pos $$textref = pos $$textref||0); - unless ($$textref =~ m/\G$pre/gc) - { - _failmsg "Did not find prefix: /$pre/", $startpos; - return; - } - - $ldelpos = pos $$textref; - - unless ($$textref =~ m/\G($ldel)/gc) - { - _failmsg "Did not find opening bracket after prefix: \"$pre\"", - pos $$textref; - pos $$textref = $startpos; - return; - } - - my @nesting = ( $1 ); - my $textlen = length $$textref; - while (pos $$textref < $textlen) - { - next if $$textref =~ m/\G\\./gcs; - - if ($$textref =~ m/\G($ldel)/gc) - { - push @nesting, $1; - } - elsif ($$textref =~ m/\G($rdel)/gc) - { - my ($found, $brackettype) = ($1, $1); - if ($#nesting < 0) - { - _failmsg "Unmatched closing bracket: \"$found\"", - pos $$textref; - pos $$textref = $startpos; - return; - } - my $expected = pop(@nesting); - $expected =~ tr/({[</)}]>/; - if ($expected ne $brackettype) - { - _failmsg qq{Mismatched closing bracket: expected "$expected" but found "$found"}, - pos $$textref; - pos $$textref = $startpos; - return; - } - last if $#nesting < 0; - } - elsif ($qdel && $$textref =~ m/\G([$qdel])/gc) - { - $$textref =~ m/\G[^\\$1]*(?:\\.[^\\$1]*)*(\Q$1\E)/gsc and next; - _failmsg "Unmatched embedded quote ($1)", - pos $$textref; - pos $$textref = $startpos; - return; - } - elsif ($quotelike && _match_quotelike($textref,"",1,0)) - { - next; - } - - else { $$textref =~ m/\G(?:[a-zA-Z0-9]+|.)/gcs } - } - if ($#nesting>=0) - { - _failmsg "Unmatched opening bracket(s): " - . join("..",@nesting)."..", - pos $$textref; - pos $$textref = $startpos; - return; - } - - $endpos = pos $$textref; - - return ( - $startpos, $ldelpos-$startpos, # PREFIX - $ldelpos, 1, # OPENING BRACKET - $ldelpos+1, $endpos-$ldelpos-2, # CONTENTS - $endpos-1, 1, # CLOSING BRACKET - $endpos, length($$textref)-$endpos, # REMAINDER - ); + my ($textref, $pre, $ldel, $qdel, $quotelike, $rdel) = @_; + my ($startpos, $ldelpos, $endpos) = (pos $$textref = pos $$textref||0); + unless ($$textref =~ m/\G$pre/gc) + { + _failmsg "Did not find prefix: /$pre/", $startpos; + return; + } + + $ldelpos = pos $$textref; + + unless ($$textref =~ m/\G($ldel)/gc) + { + _failmsg "Did not find opening bracket after prefix: \"$pre\"", + pos $$textref; + pos $$textref = $startpos; + return; + } + + my @nesting = ( $1 ); + my $textlen = length $$textref; + while (pos $$textref < $textlen) + { + next if $$textref =~ m/\G\\./gcs; + + if ($$textref =~ m/\G($ldel)/gc) + { + push @nesting, $1; + } + elsif ($$textref =~ m/\G($rdel)/gc) + { + my ($found, $brackettype) = ($1, $1); + if ($#nesting < 0) + { + _failmsg "Unmatched closing bracket: \"$found\"", + pos $$textref; + pos $$textref = $startpos; + return; + } + my $expected = pop(@nesting); + $expected =~ tr/({[</)}]>/; + if ($expected ne $brackettype) + { + _failmsg qq{Mismatched closing bracket: expected "$expected" but found "$found"}, + pos $$textref; + pos $$textref = $startpos; + return; + } + last if $#nesting < 0; + } + elsif ($qdel && $$textref =~ m/\G([$qdel])/gc) + { + $$textref =~ m/\G[^\\$1]*(?:\\.[^\\$1]*)*(\Q$1\E)/gsc and next; + _failmsg "Unmatched embedded quote ($1)", + pos $$textref; + pos $$textref = $startpos; + return; + } + elsif ($quotelike && _match_quotelike($textref,"",1,0)) + { + next; + } + + else { $$textref =~ m/\G(?:[a-zA-Z0-9]+|.)/gcs } + } + if ($#nesting>=0) + { + _failmsg "Unmatched opening bracket(s): " + . join("..",@nesting)."..", + pos $$textref; + pos $$textref = $startpos; + return; + } + + $endpos = pos $$textref; + + return ( + $startpos, $ldelpos-$startpos, # PREFIX + $ldelpos, 1, # OPENING BRACKET + $ldelpos+1, $endpos-$ldelpos-2, # CONTENTS + $endpos-1, 1, # CLOSING BRACKET + $endpos, length($$textref)-$endpos, # REMAINDER + ); } sub _revbracket($) { - my $brack = reverse $_[0]; - $brack =~ tr/[({</])}>/; - return $brack; + my $brack = reverse $_[0]; + $brack =~ tr/[({</])}>/; + return $brack; } my $XMLNAME = q{[a-zA-Z_:][a-zA-Z0-9_:.-]*}; sub extract_tagged (;$$$$$) # ($text, $opentag, $closetag, $pre, \%options) { - my $textref = defined $_[0] ? \$_[0] : \$_; - my $ldel = $_[1]; - my $rdel = $_[2]; - my $pre = defined $_[3] ? $_[3] : '\s*'; - my %options = defined $_[4] ? %{$_[4]} : (); - my $omode = defined $options{fail} ? $options{fail} : ''; - my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}}) - : defined($options{reject}) ? $options{reject} - : '' - ; - my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}}) - : defined($options{ignore}) ? $options{ignore} - : '' - ; - - if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; } - $@ = undef; - - my @match = _match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore); - - return _fail(wantarray, $textref) unless @match; - return _succeed wantarray, $textref, - $match[2], $match[3]+$match[5]+$match[7], # MATCH - @match[8..9,0..1,2..7]; # REM, PRE, BITS + my $textref = defined $_[0] ? \$_[0] : \$_; + my $ldel = $_[1]; + my $rdel = $_[2]; + my $pre = defined $_[3] ? $_[3] : '\s*'; + my %options = defined $_[4] ? %{$_[4]} : (); + my $omode = defined $options{fail} ? $options{fail} : ''; + my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}}) + : defined($options{reject}) ? $options{reject} + : '' + ; + my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}}) + : defined($options{ignore}) ? $options{ignore} + : '' + ; + + if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; } + $@ = undef; + + my @match = _match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore); + + return _fail(wantarray, $textref) unless @match; + return _succeed wantarray, $textref, + $match[2], $match[3]+$match[5]+$match[7], # MATCH + @match[8..9,0..1,2..7]; # REM, PRE, BITS } -sub _match_tagged # ($$$$$$$) +sub _match_tagged # ($$$$$$$) { - my ($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore) = @_; - my $rdelspec; - - my ($startpos, $opentagpos, $textpos, $parapos, $closetagpos, $endpos) = ( pos($$textref) = pos($$textref)||0 ); - - unless ($$textref =~ m/\G($pre)/gc) - { - _failmsg "Did not find prefix: /$pre/", pos $$textref; - goto failed; - } - - $opentagpos = pos($$textref); - - unless ($$textref =~ m/\G$ldel/gc) - { - _failmsg "Did not find opening tag: /$ldel/", pos $$textref; - goto failed; - } - - $textpos = pos($$textref); - - if (!defined $rdel) - { - $rdelspec = substr($$textref, $-[0], $+[0] - $-[0]); - unless ($rdelspec =~ s/\A([[(<{]+)($XMLNAME).*/ quotemeta "$1\/$2". _revbracket($1) /oes) - { - _failmsg "Unable to construct closing tag to match: $rdel", - pos $$textref; - goto failed; - } - } - else - { - $rdelspec = eval "qq{$rdel}" || do { - my $del; - for (qw,~ ! ^ & * ) _ + - = } ] : " ; ' > . ? / | ',) - { next if $rdel =~ /\Q$_/; $del = $_; last } - unless ($del) { - use Carp; - croak "Can't interpolate right delimiter $rdel" - } - eval "qq$del$rdel$del"; - }; - } - - while (pos($$textref) < length($$textref)) - { - next if $$textref =~ m/\G\\./gc; - - if ($$textref =~ m/\G(\n[ \t]*\n)/gc ) - { - $parapos = pos($$textref) - length($1) - unless defined $parapos; - } - elsif ($$textref =~ m/\G($rdelspec)/gc ) - { - $closetagpos = pos($$textref)-length($1); - goto matched; - } - elsif ($ignore && $$textref =~ m/\G(?:$ignore)/gc) - { - next; - } - elsif ($bad && $$textref =~ m/\G($bad)/gcs) - { - pos($$textref) -= length($1); # CUT OFF WHATEVER CAUSED THE SHORTNESS - goto short if ($omode eq 'PARA' || $omode eq 'MAX'); - _failmsg "Found invalid nested tag: $1", pos $$textref; - goto failed; - } - elsif ($$textref =~ m/\G($ldel)/gc) - { - my $tag = $1; - pos($$textref) -= length($tag); # REWIND TO NESTED TAG - unless (_match_tagged(@_)) # MATCH NESTED TAG - { - goto short if $omode eq 'PARA' || $omode eq 'MAX'; - _failmsg "Found unbalanced nested tag: $tag", - pos $$textref; - goto failed; - } - } - else { $$textref =~ m/./gcs } - } + my ($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore) = @_; + my $rdelspec; + + my ($startpos, $opentagpos, $textpos, $parapos, $closetagpos, $endpos) = ( pos($$textref) = pos($$textref)||0 ); + + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg "Did not find prefix: /$pre/", pos $$textref; + goto failed; + } + + $opentagpos = pos($$textref); + + unless ($$textref =~ m/\G$ldel/gc) + { + _failmsg "Did not find opening tag: /$ldel/", pos $$textref; + goto failed; + } + + $textpos = pos($$textref); + + if (!defined $rdel) + { + $rdelspec = substr($$textref, $-[0], $+[0] - $-[0]); + unless ($rdelspec =~ s/\A([[(<{]+)($XMLNAME).*/ quotemeta "$1\/$2". _revbracket($1) /oes) + { + _failmsg "Unable to construct closing tag to match: $rdel", + pos $$textref; + goto failed; + } + } + else + { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + $rdelspec = eval "qq{$rdel}" || do { + my $del; + for (qw,~ ! ^ & * ) _ + - = } ] : " ; ' > . ? / | ',) + { next if $rdel =~ /\Q$_/; $del = $_; last } + unless ($del) { + use Carp; + croak "Can't interpolate right delimiter $rdel" + } + eval "qq$del$rdel$del"; + }; + } + + while (pos($$textref) < length($$textref)) + { + next if $$textref =~ m/\G\\./gc; + + if ($$textref =~ m/\G(\n[ \t]*\n)/gc ) + { + $parapos = pos($$textref) - length($1) + unless defined $parapos; + } + elsif ($$textref =~ m/\G($rdelspec)/gc ) + { + $closetagpos = pos($$textref)-length($1); + goto matched; + } + elsif ($ignore && $$textref =~ m/\G(?:$ignore)/gc) + { + next; + } + elsif ($bad && $$textref =~ m/\G($bad)/gcs) + { + pos($$textref) -= length($1); # CUT OFF WHATEVER CAUSED THE SHORTNESS + goto short if ($omode eq 'PARA' || $omode eq 'MAX'); + _failmsg "Found invalid nested tag: $1", pos $$textref; + goto failed; + } + elsif ($$textref =~ m/\G($ldel)/gc) + { + my $tag = $1; + pos($$textref) -= length($tag); # REWIND TO NESTED TAG + unless (_match_tagged(@_)) # MATCH NESTED TAG + { + goto short if $omode eq 'PARA' || $omode eq 'MAX'; + _failmsg "Found unbalanced nested tag: $tag", + pos $$textref; + goto failed; + } + } + else { $$textref =~ m/./gcs } + } short: - $closetagpos = pos($$textref); - goto matched if $omode eq 'MAX'; - goto failed unless $omode eq 'PARA'; - - if (defined $parapos) { pos($$textref) = $parapos } - else { $parapos = pos($$textref) } - - return ( - $startpos, $opentagpos-$startpos, # PREFIX - $opentagpos, $textpos-$opentagpos, # OPENING TAG - $textpos, $parapos-$textpos, # TEXT - $parapos, 0, # NO CLOSING TAG - $parapos, length($$textref)-$parapos, # REMAINDER - ); - + $closetagpos = pos($$textref); + goto matched if $omode eq 'MAX'; + goto failed unless $omode eq 'PARA'; + + if (defined $parapos) { pos($$textref) = $parapos } + else { $parapos = pos($$textref) } + + return ( + $startpos, $opentagpos-$startpos, # PREFIX + $opentagpos, $textpos-$opentagpos, # OPENING TAG + $textpos, $parapos-$textpos, # TEXT + $parapos, 0, # NO CLOSING TAG + $parapos, length($$textref)-$parapos, # REMAINDER + ); + matched: - $endpos = pos($$textref); - return ( - $startpos, $opentagpos-$startpos, # PREFIX - $opentagpos, $textpos-$opentagpos, # OPENING TAG - $textpos, $closetagpos-$textpos, # TEXT - $closetagpos, $endpos-$closetagpos, # CLOSING TAG - $endpos, length($$textref)-$endpos, # REMAINDER - ); + $endpos = pos($$textref); + return ( + $startpos, $opentagpos-$startpos, # PREFIX + $opentagpos, $textpos-$opentagpos, # OPENING TAG + $textpos, $closetagpos-$textpos, # TEXT + $closetagpos, $endpos-$closetagpos, # CLOSING TAG + $endpos, length($$textref)-$endpos, # REMAINDER + ); failed: - _failmsg "Did not find closing tag", pos $$textref unless $@; - pos($$textref) = $startpos; - return; + _failmsg "Did not find closing tag", pos $$textref unless $@; + pos($$textref) = $startpos; + return; } sub extract_variable (;$$) { - my $textref = defined $_[0] ? \$_[0] : \$_; - return ("","","") unless defined $$textref; - my $pre = defined $_[1] ? $_[1] : '\s*'; + my $textref = defined $_[0] ? \$_[0] : \$_; + return ("","","") unless defined $$textref; + my $pre = defined $_[1] ? $_[1] : '\s*'; - my @match = _match_variable($textref,$pre); + my @match = _match_variable($textref,$pre); - return _fail wantarray, $textref unless @match; + return _fail wantarray, $textref unless @match; - return _succeed wantarray, $textref, - @match[2..3,4..5,0..1]; # MATCH, REMAINDER, PREFIX + return _succeed wantarray, $textref, + @match[2..3,4..5,0..1]; # MATCH, REMAINDER, PREFIX } sub _match_variable($$) @@ -438,582 +448,581 @@ sub _match_variable($$) # $# # $^ # $$ - my ($textref, $pre) = @_; - my $startpos = pos($$textref) = pos($$textref)||0; - unless ($$textref =~ m/\G($pre)/gc) - { - _failmsg "Did not find prefix: /$pre/", pos $$textref; - return; - } - my $varpos = pos($$textref); - unless ($$textref =~ m{\G\$\s*(?!::)(\d+|[][&`'+*./|,";%=~:?!\@<>()-]|\^[a-z]?)}gci) - { - unless ($$textref =~ m/\G((\$#?|[*\@\%]|\\&)+)/gc) - { - _failmsg "Did not find leading dereferencer", pos $$textref; - pos $$textref = $startpos; - return; - } - my $deref = $1; - - unless ($$textref =~ m/\G\s*(?:::|')?(?:[_a-z]\w*(?:::|'))*[_a-z]\w*/gci - or _match_codeblock($textref, "", '\{', '\}', '\{', '\}', 0) - or $deref eq '$#' or $deref eq '$$' ) - { - _failmsg "Bad identifier after dereferencer", pos $$textref; - pos $$textref = $startpos; - return; - } - } - - while (1) - { - next if $$textref =~ m/\G\s*(?:->)?\s*[{]\w+[}]/gc; - next if _match_codeblock($textref, - qr/\s*->\s*(?:[_a-zA-Z]\w+\s*)?/, - qr/[({[]/, qr/[)}\]]/, - qr/[({[]/, qr/[)}\]]/, 0); - next if _match_codeblock($textref, - qr/\s*/, qr/[{[]/, qr/[}\]]/, - qr/[{[]/, qr/[}\]]/, 0); - next if _match_variable($textref,'\s*->\s*'); - next if $$textref =~ m/\G\s*->\s*\w+(?![{([])/gc; - last; - } - - my $endpos = pos($$textref); - return ($startpos, $varpos-$startpos, - $varpos, $endpos-$varpos, - $endpos, length($$textref)-$endpos - ); + my ($textref, $pre) = @_; + my $startpos = pos($$textref) = pos($$textref)||0; + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg "Did not find prefix: /$pre/", pos $$textref; + return; + } + my $varpos = pos($$textref); + unless ($$textref =~ m{\G\$\s*(?!::)(\d+|[][&`'+*./|,";%=~:?!\@<>()-]|\^[a-z]?)}gci) + { + unless ($$textref =~ m/\G((\$#?|[*\@\%]|\\&)+)/gc) + { + _failmsg "Did not find leading dereferencer", pos $$textref; + pos $$textref = $startpos; + return; + } + my $deref = $1; + + unless ($$textref =~ m/\G\s*(?:::|')?(?:[_a-z]\w*(?:::|'))*[_a-z]\w*/gci + or _match_codeblock($textref, "", '\{', '\}', '\{', '\}', 0) + or $deref eq '$#' or $deref eq '$$' ) + { + _failmsg "Bad identifier after dereferencer", pos $$textref; + pos $$textref = $startpos; + return; + } + } + + while (1) + { + next if $$textref =~ m/\G\s*(?:->)?\s*[{]\w+[}]/gc; + next if _match_codeblock($textref, + qr/\s*->\s*(?:[_a-zA-Z]\w+\s*)?/, + qr/[({[]/, qr/[)}\]]/, + qr/[({[]/, qr/[)}\]]/, 0); + next if _match_codeblock($textref, + qr/\s*/, qr/[{[]/, qr/[}\]]/, + qr/[{[]/, qr/[}\]]/, 0); + next if _match_variable($textref,'\s*->\s*'); + next if $$textref =~ m/\G\s*->\s*\w+(?![{([])/gc; + last; + } + + my $endpos = pos($$textref); + return ($startpos, $varpos-$startpos, + $varpos, $endpos-$varpos, + $endpos, length($$textref)-$endpos + ); } sub extract_codeblock (;$$$$$) { - my $textref = defined $_[0] ? \$_[0] : \$_; - my $wantarray = wantarray; - my $ldel_inner = defined $_[1] ? $_[1] : '{'; - my $pre = defined $_[2] ? $_[2] : '\s*'; - my $ldel_outer = defined $_[3] ? $_[3] : $ldel_inner; - my $rd = $_[4]; - my $rdel_inner = $ldel_inner; - my $rdel_outer = $ldel_outer; - my $posbug = pos; - for ($ldel_inner, $ldel_outer) { tr/[]()<>{}\0-\377/[[((<<{{/ds } - for ($rdel_inner, $rdel_outer) { tr/[]()<>{}\0-\377/]]))>>}}/ds } - for ($ldel_inner, $ldel_outer, $rdel_inner, $rdel_outer) - { - $_ = '('.join('|',map { quotemeta $_ } split('',$_)).')' - } - pos = $posbug; - - my @match = _match_codeblock($textref, $pre, - $ldel_outer, $rdel_outer, - $ldel_inner, $rdel_inner, - $rd); - return _fail($wantarray, $textref) unless @match; - return _succeed($wantarray, $textref, - @match[2..3,4..5,0..1] # MATCH, REMAINDER, PREFIX - ); + my $textref = defined $_[0] ? \$_[0] : \$_; + my $wantarray = wantarray; + my $ldel_inner = defined $_[1] ? $_[1] : '{'; + my $pre = defined $_[2] ? $_[2] : '\s*'; + my $ldel_outer = defined $_[3] ? $_[3] : $ldel_inner; + my $rd = $_[4]; + my $rdel_inner = $ldel_inner; + my $rdel_outer = $ldel_outer; + my $posbug = pos; + for ($ldel_inner, $ldel_outer) { tr/[]()<>{}\0-\377/[[((<<{{/ds } + for ($rdel_inner, $rdel_outer) { tr/[]()<>{}\0-\377/]]))>>}}/ds } + for ($ldel_inner, $ldel_outer, $rdel_inner, $rdel_outer) + { + $_ = '('.join('|',map { quotemeta $_ } split('',$_)).')' + } + pos = $posbug; + + my @match = _match_codeblock($textref, $pre, + $ldel_outer, $rdel_outer, + $ldel_inner, $rdel_inner, + $rd); + return _fail($wantarray, $textref) unless @match; + return _succeed($wantarray, $textref, + @match[2..3,4..5,0..1] # MATCH, REMAINDER, PREFIX + ); } sub _match_codeblock($$$$$$$) { - my ($textref, $pre, $ldel_outer, $rdel_outer, $ldel_inner, $rdel_inner, $rd) = @_; - my $startpos = pos($$textref) = pos($$textref) || 0; - unless ($$textref =~ m/\G($pre)/gc) - { - _failmsg qq{Did not match prefix /$pre/ at"} . - substr($$textref,pos($$textref),20) . - q{..."}, - pos $$textref; - return; - } - my $codepos = pos($$textref); - unless ($$textref =~ m/\G($ldel_outer)/gc) # OUTERMOST DELIMITER - { - _failmsg qq{Did not find expected opening bracket at "} . - substr($$textref,pos($$textref),20) . - q{..."}, - pos $$textref; - pos $$textref = $startpos; - return; - } - my $closing = $1; - $closing =~ tr/([<{/)]>}/; - my $matched; - my $patvalid = 1; - while (pos($$textref) < length($$textref)) - { - $matched = ''; - if ($rd && $$textref =~ m#\G(\Q(?)\E|\Q(s?)\E|\Q(s)\E)#gc) - { - $patvalid = 0; - next; - } - - if ($$textref =~ m/\G\s*#.*/gc) - { - next; - } - - if ($$textref =~ m/\G\s*($rdel_outer)/gc) - { - unless ($matched = ($closing && $1 eq $closing) ) - { - next if $1 eq '>'; # MIGHT BE A "LESS THAN" - _failmsg q{Mismatched closing bracket at "} . - substr($$textref,pos($$textref),20) . - qq{...". Expected '$closing'}, - pos $$textref; - } - last; - } - - if (_match_variable($textref,'\s*') || - _match_quotelike($textref,'\s*',$patvalid,$patvalid) ) - { - $patvalid = 0; - next; - } - - - # NEED TO COVER MANY MORE CASES HERE!!! - if ($$textref =~ m#\G\s*(?!$ldel_inner) - ( [-+*x/%^&|.]=? - | [!=]~ - | =(?!>) - | (\*\*|&&|\|\||<<|>>)=? - | split|grep|map|return - | [([] - )#gcx) - { - $patvalid = 1; - next; - } - - if ( _match_codeblock($textref, '\s*', $ldel_inner, $rdel_inner, $ldel_inner, $rdel_inner, $rd) ) - { - $patvalid = 1; - next; - } - - if ($$textref =~ m/\G\s*$ldel_outer/gc) - { - _failmsg q{Improperly nested codeblock at "} . - substr($$textref,pos($$textref),20) . - q{..."}, - pos $$textref; - last; - } - - $patvalid = 0; - $$textref =~ m/\G\s*(\w+|[-=>]>|.|\Z)/gc; - } - continue { $@ = undef } - - unless ($matched) - { - _failmsg 'No match found for opening bracket', pos $$textref - unless $@; - return; - } - - my $endpos = pos($$textref); - return ( $startpos, $codepos-$startpos, - $codepos, $endpos-$codepos, - $endpos, length($$textref)-$endpos, - ); + my ($textref, $pre, $ldel_outer, $rdel_outer, $ldel_inner, $rdel_inner, $rd) = @_; + my $startpos = pos($$textref) = pos($$textref) || 0; + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg qq{Did not match prefix /$pre/ at"} . + substr($$textref,pos($$textref),20) . + q{..."}, + pos $$textref; + return; + } + my $codepos = pos($$textref); + unless ($$textref =~ m/\G($ldel_outer)/gc) # OUTERMOST DELIMITER + { + _failmsg qq{Did not find expected opening bracket at "} . + substr($$textref,pos($$textref),20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + my $closing = $1; + $closing =~ tr/([<{/)]>}/; + my $matched; + my $patvalid = 1; + while (pos($$textref) < length($$textref)) + { + $matched = ''; + if ($rd && $$textref =~ m#\G(\Q(?)\E|\Q(s?)\E|\Q(s)\E)#gc) + { + $patvalid = 0; + next; + } + + if ($$textref =~ m/\G\s*#.*/gc) + { + next; + } + + if ($$textref =~ m/\G\s*($rdel_outer)/gc) + { + unless ($matched = ($closing && $1 eq $closing) ) + { + next if $1 eq '>'; # MIGHT BE A "LESS THAN" + _failmsg q{Mismatched closing bracket at "} . + substr($$textref,pos($$textref),20) . + qq{...". Expected '$closing'}, + pos $$textref; + } + last; + } + + if (_match_variable($textref,'\s*') || + _match_quotelike($textref,'\s*',$patvalid,$patvalid) ) + { + $patvalid = 0; + next; + } + + + # NEED TO COVER MANY MORE CASES HERE!!! + if ($$textref =~ m#\G\s*(?!$ldel_inner) + ( [-+*x/%^&|.]=? + | [!=]~ + | =(?!>) + | (\*\*|&&|\|\||<<|>>)=? + | split|grep|map|return + | [([] + )#gcx) + { + $patvalid = 1; + next; + } + + if ( _match_codeblock($textref, '\s*', $ldel_inner, $rdel_inner, $ldel_inner, $rdel_inner, $rd) ) + { + $patvalid = 1; + next; + } + + if ($$textref =~ m/\G\s*$ldel_outer/gc) + { + _failmsg q{Improperly nested codeblock at "} . + substr($$textref,pos($$textref),20) . + q{..."}, + pos $$textref; + last; + } + + $patvalid = 0; + $$textref =~ m/\G\s*(\w+|[-=>]>|.|\Z)/gc; + } + continue { $@ = undef } + + unless ($matched) + { + _failmsg 'No match found for opening bracket', pos $$textref + unless $@; + return; + } + + my $endpos = pos($$textref); + return ( $startpos, $codepos-$startpos, + $codepos, $endpos-$codepos, + $endpos, length($$textref)-$endpos, + ); } my %mods = ( - 'none' => '[cgimsox]*', - 'm' => '[cgimsox]*', - 's' => '[cegimsox]*', - 'tr' => '[cds]*', - 'y' => '[cds]*', - 'qq' => '', - 'qx' => '', - 'qw' => '', - 'qr' => '[imsx]*', - 'q' => '', - ); + 'none' => '[cgimsox]*', + 'm' => '[cgimsox]*', + 's' => '[cegimsox]*', + 'tr' => '[cds]*', + 'y' => '[cds]*', + 'qq' => '', + 'qx' => '', + 'qw' => '', + 'qr' => '[imsx]*', + 'q' => '', +); sub extract_quotelike (;$$) { - my $textref = $_[0] ? \$_[0] : \$_; - my $wantarray = wantarray; - my $pre = defined $_[1] ? $_[1] : '\s*'; - - my @match = _match_quotelike($textref,$pre,1,0); - return _fail($wantarray, $textref) unless @match; - return _succeed($wantarray, $textref, - $match[2], $match[18]-$match[2], # MATCH - @match[18,19], # REMAINDER - @match[0,1], # PREFIX - @match[2..17], # THE BITS - @match[20,21], # ANY FILLET? - ); + my $textref = $_[0] ? \$_[0] : \$_; + my $wantarray = wantarray; + my $pre = defined $_[1] ? $_[1] : '\s*'; + + my @match = _match_quotelike($textref,$pre,1,0); + return _fail($wantarray, $textref) unless @match; + return _succeed($wantarray, $textref, + $match[2], $match[18]-$match[2], # MATCH + @match[18,19], # REMAINDER + @match[0,1], # PREFIX + @match[2..17], # THE BITS + @match[20,21], # ANY FILLET? + ); }; -sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) +sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) { - my ($textref, $pre, $rawmatch, $qmark) = @_; - - my ($textlen,$startpos, - $oppos, - $preld1pos,$ld1pos,$str1pos,$rd1pos, - $preld2pos,$ld2pos,$str2pos,$rd2pos, - $modpos) = ( length($$textref), pos($$textref) = pos($$textref) || 0 ); - - unless ($$textref =~ m/\G($pre)/gc) - { - _failmsg qq{Did not find prefix /$pre/ at "} . - substr($$textref, pos($$textref), 20) . - q{..."}, - pos $$textref; - return; - } - $oppos = pos($$textref); - - my $initial = substr($$textref,$oppos,1); - - if ($initial && $initial =~ m|^[\"\'\`]| - || $rawmatch && $initial =~ m|^/| - || $qmark && $initial =~ m|^\?|) - { - unless ($$textref =~ m/ \Q$initial\E [^\\$initial]* (\\.[^\\$initial]*)* \Q$initial\E /gcsx) - { - _failmsg qq{Did not find closing delimiter to match '$initial' at "} . - substr($$textref, $oppos, 20) . - q{..."}, - pos $$textref; - pos $$textref = $startpos; - return; - } - $modpos= pos($$textref); - $rd1pos = $modpos-1; - - if ($initial eq '/' || $initial eq '?') - { - $$textref =~ m/\G$mods{none}/gc - } - - my $endpos = pos($$textref); - return ( - $startpos, $oppos-$startpos, # PREFIX - $oppos, 0, # NO OPERATOR - $oppos, 1, # LEFT DEL - $oppos+1, $rd1pos-$oppos-1, # STR/PAT - $rd1pos, 1, # RIGHT DEL - $modpos, 0, # NO 2ND LDEL - $modpos, 0, # NO 2ND STR - $modpos, 0, # NO 2ND RDEL - $modpos, $endpos-$modpos, # MODIFIERS - $endpos, $textlen-$endpos, # REMAINDER - ); - } - - unless ($$textref =~ m{\G(\b(?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<)}gc) - { - _failmsg q{No quotelike operator found after prefix at "} . - substr($$textref, pos($$textref), 20) . - q{..."}, - pos $$textref; - pos $$textref = $startpos; - return; - } - - my $op = $1; - $preld1pos = pos($$textref); - if ($op eq '<<') { - $ld1pos = pos($$textref); - my $label; - if ($$textref =~ m{\G([A-Za-z_]\w*)}gc) { - $label = $1; - } - elsif ($$textref =~ m{ \G ' ([^'\\]* (?:\\.[^'\\]*)*) ' - | \G " ([^"\\]* (?:\\.[^"\\]*)*) " - | \G ` ([^`\\]* (?:\\.[^`\\]*)*) ` - }gcsx) { - $label = $+; - } - else { - $label = ""; - } - my $extrapos = pos($$textref); - $$textref =~ m{.*\n}gc; - $str1pos = pos($$textref)--; - unless ($$textref =~ m{.*?\n(?=\Q$label\E\n)}gc) { - _failmsg qq{Missing here doc terminator ('$label') after "} . - substr($$textref, $startpos, 20) . - q{..."}, - pos $$textref; - pos $$textref = $startpos; - return; - } - $rd1pos = pos($$textref); + my ($textref, $pre, $rawmatch, $qmark) = @_; + + my ($textlen,$startpos, + $oppos, + $preld1pos,$ld1pos,$str1pos,$rd1pos, + $preld2pos,$ld2pos,$str2pos,$rd2pos, + $modpos) = ( length($$textref), pos($$textref) = pos($$textref) || 0 ); + + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg qq{Did not find prefix /$pre/ at "} . + substr($$textref, pos($$textref), 20) . + q{..."}, + pos $$textref; + return; + } + $oppos = pos($$textref); + + my $initial = substr($$textref,$oppos,1); + + if ($initial && $initial =~ m|^[\"\'\`]| + || $rawmatch && $initial =~ m|^/| + || $qmark && $initial =~ m|^\?|) + { + unless ($$textref =~ m/ \Q$initial\E [^\\$initial]* (\\.[^\\$initial]*)* \Q$initial\E /gcsx) + { + _failmsg qq{Did not find closing delimiter to match '$initial' at "} . + substr($$textref, $oppos, 20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + $modpos= pos($$textref); + $rd1pos = $modpos-1; + + if ($initial eq '/' || $initial eq '?') + { + $$textref =~ m/\G$mods{none}/gc + } + + my $endpos = pos($$textref); + return ( + $startpos, $oppos-$startpos, # PREFIX + $oppos, 0, # NO OPERATOR + $oppos, 1, # LEFT DEL + $oppos+1, $rd1pos-$oppos-1, # STR/PAT + $rd1pos, 1, # RIGHT DEL + $modpos, 0, # NO 2ND LDEL + $modpos, 0, # NO 2ND STR + $modpos, 0, # NO 2ND RDEL + $modpos, $endpos-$modpos, # MODIFIERS + $endpos, $textlen-$endpos, # REMAINDER + ); + } + + unless ($$textref =~ m{\G(\b(?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<)}gc) + { + _failmsg q{No quotelike operator found after prefix at "} . + substr($$textref, pos($$textref), 20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + + my $op = $1; + $preld1pos = pos($$textref); + if ($op eq '<<') { + $ld1pos = pos($$textref); + my $label; + if ($$textref =~ m{\G([A-Za-z_]\w*)}gc) { + $label = $1; + } + elsif ($$textref =~ m{ \G ' ([^'\\]* (?:\\.[^'\\]*)*) ' + | \G " ([^"\\]* (?:\\.[^"\\]*)*) " + | \G ` ([^`\\]* (?:\\.[^`\\]*)*) ` + }gcsx) { + $label = $+; + } + else { + $label = ""; + } + my $extrapos = pos($$textref); + $$textref =~ m{.*\n}gc; + $str1pos = pos($$textref)--; + unless ($$textref =~ m{.*?\n(?=\Q$label\E\n)}gc) { + _failmsg qq{Missing here doc terminator ('$label') after "} . + substr($$textref, $startpos, 20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + $rd1pos = pos($$textref); $$textref =~ m{\Q$label\E\n}gc; - $ld2pos = pos($$textref); - return ( - $startpos, $oppos-$startpos, # PREFIX - $oppos, length($op), # OPERATOR - $ld1pos, $extrapos-$ld1pos, # LEFT DEL - $str1pos, $rd1pos-$str1pos, # STR/PAT - $rd1pos, $ld2pos-$rd1pos, # RIGHT DEL - $ld2pos, 0, # NO 2ND LDEL - $ld2pos, 0, # NO 2ND STR - $ld2pos, 0, # NO 2ND RDEL - $ld2pos, 0, # NO MODIFIERS - $ld2pos, $textlen-$ld2pos, # REMAINDER - $extrapos, $str1pos-$extrapos, # FILLETED BIT - ); - } - - $$textref =~ m/\G\s*/gc; - $ld1pos = pos($$textref); - $str1pos = $ld1pos+1; - - unless ($$textref =~ m/\G(\S)/gc) # SHOULD USE LOOKAHEAD - { - _failmsg "No block delimiter found after quotelike $op", - pos $$textref; - pos $$textref = $startpos; - return; - } - pos($$textref) = $ld1pos; # HAVE TO DO THIS BECAUSE LOOKAHEAD BROKEN - my ($ldel1, $rdel1) = ("\Q$1","\Q$1"); - if ($ldel1 =~ /[[(<{]/) - { - $rdel1 =~ tr/[({</])}>/; - defined(_match_bracketed($textref,"",$ldel1,"","",$rdel1)) - || do { pos $$textref = $startpos; return }; + $ld2pos = pos($$textref); + return ( + $startpos, $oppos-$startpos, # PREFIX + $oppos, length($op), # OPERATOR + $ld1pos, $extrapos-$ld1pos, # LEFT DEL + $str1pos, $rd1pos-$str1pos, # STR/PAT + $rd1pos, $ld2pos-$rd1pos, # RIGHT DEL + $ld2pos, 0, # NO 2ND LDEL + $ld2pos, 0, # NO 2ND STR + $ld2pos, 0, # NO 2ND RDEL + $ld2pos, 0, # NO MODIFIERS + $ld2pos, $textlen-$ld2pos, # REMAINDER + $extrapos, $str1pos-$extrapos, # FILLETED BIT + ); + } + + $$textref =~ m/\G\s*/gc; + $ld1pos = pos($$textref); + $str1pos = $ld1pos+1; + + unless ($$textref =~ m/\G(\S)/gc) # SHOULD USE LOOKAHEAD + { + _failmsg "No block delimiter found after quotelike $op", + pos $$textref; + pos $$textref = $startpos; + return; + } + pos($$textref) = $ld1pos; # HAVE TO DO THIS BECAUSE LOOKAHEAD BROKEN + my ($ldel1, $rdel1) = ("\Q$1","\Q$1"); + if ($ldel1 =~ /[[(<{]/) + { + $rdel1 =~ tr/[({</])}>/; + defined(_match_bracketed($textref,"",$ldel1,"","",$rdel1)) + || do { pos $$textref = $startpos; return }; $ld2pos = pos($$textref); $rd1pos = $ld2pos-1; - } - else - { - $$textref =~ /\G$ldel1[^\\$ldel1]*(\\.[^\\$ldel1]*)*$ldel1/gcs - || do { pos $$textref = $startpos; return }; + } + else + { + $$textref =~ /\G$ldel1[^\\$ldel1]*(\\.[^\\$ldel1]*)*$ldel1/gcs + || do { pos $$textref = $startpos; return }; $ld2pos = $rd1pos = pos($$textref)-1; - } - - my $second_arg = $op =~ /s|tr|y/ ? 1 : 0; - if ($second_arg) - { - my ($ldel2, $rdel2); - if ($ldel1 =~ /[[(<{]/) - { - unless ($$textref =~ /\G\s*(\S)/gc) # SHOULD USE LOOKAHEAD - { - _failmsg "Missing second block for quotelike $op", - pos $$textref; - pos $$textref = $startpos; - return; - } - $ldel2 = $rdel2 = "\Q$1"; - $rdel2 =~ tr/[({</])}>/; - } - else - { - $ldel2 = $rdel2 = $ldel1; - } - $str2pos = $ld2pos+1; - - if ($ldel2 =~ /[[(<{]/) - { - pos($$textref)--; # OVERCOME BROKEN LOOKAHEAD - defined(_match_bracketed($textref,"",$ldel2,"","",$rdel2)) - || do { pos $$textref = $startpos; return }; - } - else - { - $$textref =~ /[^\\$ldel2]*(\\.[^\\$ldel2]*)*$ldel2/gcs - || do { pos $$textref = $startpos; return }; - } - $rd2pos = pos($$textref)-1; - } - else - { - $ld2pos = $str2pos = $rd2pos = $rd1pos; - } - - $modpos = pos $$textref; - - $$textref =~ m/\G($mods{$op})/gc; - my $endpos = pos $$textref; - - return ( - $startpos, $oppos-$startpos, # PREFIX - $oppos, length($op), # OPERATOR - $ld1pos, 1, # LEFT DEL - $str1pos, $rd1pos-$str1pos, # STR/PAT - $rd1pos, 1, # RIGHT DEL - $ld2pos, $second_arg, # 2ND LDEL (MAYBE) - $str2pos, $rd2pos-$str2pos, # 2ND STR (MAYBE) - $rd2pos, $second_arg, # 2ND RDEL (MAYBE) - $modpos, $endpos-$modpos, # MODIFIERS - $endpos, $textlen-$endpos, # REMAINDER - ); + } + + my $second_arg = $op =~ /s|tr|y/ ? 1 : 0; + if ($second_arg) + { + my ($ldel2, $rdel2); + if ($ldel1 =~ /[[(<{]/) + { + unless ($$textref =~ /\G\s*(\S)/gc) # SHOULD USE LOOKAHEAD + { + _failmsg "Missing second block for quotelike $op", + pos $$textref; + pos $$textref = $startpos; + return; + } + $ldel2 = $rdel2 = "\Q$1"; + $rdel2 =~ tr/[({</])}>/; + } + else + { + $ldel2 = $rdel2 = $ldel1; + } + $str2pos = $ld2pos+1; + + if ($ldel2 =~ /[[(<{]/) + { + pos($$textref)--; # OVERCOME BROKEN LOOKAHEAD + defined(_match_bracketed($textref,"",$ldel2,"","",$rdel2)) + || do { pos $$textref = $startpos; return }; + } + else + { + $$textref =~ /[^\\$ldel2]*(\\.[^\\$ldel2]*)*$ldel2/gcs + || do { pos $$textref = $startpos; return }; + } + $rd2pos = pos($$textref)-1; + } + else + { + $ld2pos = $str2pos = $rd2pos = $rd1pos; + } + + $modpos = pos $$textref; + + $$textref =~ m/\G($mods{$op})/gc; + my $endpos = pos $$textref; + + return ( + $startpos, $oppos-$startpos, # PREFIX + $oppos, length($op), # OPERATOR + $ld1pos, 1, # LEFT DEL + $str1pos, $rd1pos-$str1pos, # STR/PAT + $rd1pos, 1, # RIGHT DEL + $ld2pos, $second_arg, # 2ND LDEL (MAYBE) + $str2pos, $rd2pos-$str2pos, # 2ND STR (MAYBE) + $rd2pos, $second_arg, # 2ND RDEL (MAYBE) + $modpos, $endpos-$modpos, # MODIFIERS + $endpos, $textlen-$endpos, # REMAINDER + ); } my $def_func = [ - sub { extract_variable($_[0], '') }, - sub { extract_quotelike($_[0],'') }, - sub { extract_codeblock($_[0],'{}','') }, + sub { extract_variable($_[0], '') }, + sub { extract_quotelike($_[0],'') }, + sub { extract_codeblock($_[0],'{}','') }, ]; -sub extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $ignoreunknown) +sub extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $ignoreunknown) { - my $textref = defined($_[0]) ? \$_[0] : \$_; - my $posbug = pos; - my ($lastpos, $firstpos); - my @fields = (); - - #for ($$textref) - { - my @func = defined $_[1] ? @{$_[1]} : @{$def_func}; - my $max = defined $_[2] && $_[2]>0 ? $_[2] : 1_000_000_000; - my $igunk = $_[3]; - - pos $$textref ||= 0; - - unless (wantarray) - { - use Carp; - carp "extract_multiple reset maximal count to 1 in scalar context" - if $^W && defined($_[2]) && $max > 1; - $max = 1 - } - - my $unkpos; - my $func; - my $class; - - my @class; - foreach $func ( @func ) - { - if (ref($func) eq 'HASH') - { - push @class, (keys %$func)[0]; - $func = (values %$func)[0]; - } - else - { - push @class, undef; - } - } - - FIELD: while (pos($$textref) < length($$textref)) - { - my ($field, $rem); - my @bits; - foreach my $i ( 0..$#func ) - { - my $pref; - $func = $func[$i]; - $class = $class[$i]; - $lastpos = pos $$textref; - if (ref($func) eq 'CODE') - { ($field,$rem,$pref) = @bits = $func->($$textref) } - elsif (ref($func) eq 'Text::Balanced::Extractor') - { @bits = $field = $func->extract($$textref) } - elsif( $$textref =~ m/\G$func/gc ) - { @bits = $field = defined($1) - ? $1 - : substr($$textref, $-[0], $+[0] - $-[0]) + my $textref = defined($_[0]) ? \$_[0] : \$_; + my $posbug = pos; + my ($lastpos, $firstpos); + my @fields = (); + + #for ($$textref) + { + my @func = defined $_[1] ? @{$_[1]} : @{$def_func}; + my $max = defined $_[2] && $_[2]>0 ? $_[2] : 1_000_000_000; + my $igunk = $_[3]; + + pos $$textref ||= 0; + + unless (wantarray) + { + use Carp; + carp "extract_multiple reset maximal count to 1 in scalar context" + if $^W && defined($_[2]) && $max > 1; + $max = 1 + } + + my $unkpos; + my $class; + + my @class; + foreach my $func ( @func ) + { + if (ref($func) eq 'HASH') + { + push @class, (keys %$func)[0]; + $func = (values %$func)[0]; + } + else + { + push @class, undef; + } + } + + FIELD: while (pos($$textref) < length($$textref)) + { + my ($field, $rem); + my @bits; + foreach my $i ( 0..$#func ) + { + my $pref; + my $func = $func[$i]; + $class = $class[$i]; + $lastpos = pos $$textref; + if (ref($func) eq 'CODE') + { ($field,$rem,$pref) = @bits = $func->($$textref) } + elsif (ref($func) eq 'Text::Balanced::Extractor') + { @bits = $field = $func->extract($$textref) } + elsif( $$textref =~ m/\G$func/gc ) + { @bits = $field = defined($1) + ? $1 + : substr($$textref, $-[0], $+[0] - $-[0]) + } + $pref ||= ""; + if (defined($field) && length($field)) + { + if (!$igunk) { + $unkpos = $lastpos + if length($pref) && !defined($unkpos); + if (defined $unkpos) + { + push @fields, substr($$textref, $unkpos, $lastpos-$unkpos).$pref; + $firstpos = $unkpos unless defined $firstpos; + undef $unkpos; + last FIELD if @fields == $max; + } } - $pref ||= ""; - if (defined($field) && length($field)) - { - if (!$igunk) { - $unkpos = $lastpos - if length($pref) && !defined($unkpos); - if (defined $unkpos) - { - push @fields, substr($$textref, $unkpos, $lastpos-$unkpos).$pref; - $firstpos = $unkpos unless defined $firstpos; - undef $unkpos; - last FIELD if @fields == $max; - } - } - push @fields, $class - ? bless (\$field, $class) - : $field; - $firstpos = $lastpos unless defined $firstpos; - $lastpos = pos $$textref; - last FIELD if @fields == $max; - next FIELD; - } - } - if ($$textref =~ /\G(.)/gcs) - { - $unkpos = pos($$textref)-1 - unless $igunk || defined $unkpos; - } - } - - if (defined $unkpos) - { - push @fields, substr($$textref, $unkpos); - $firstpos = $unkpos unless defined $firstpos; - $lastpos = length $$textref; - } - last; - } - - pos $$textref = $lastpos; - return @fields if wantarray; - - $firstpos ||= 0; - eval { substr($$textref,$firstpos,$lastpos-$firstpos)=""; - pos $$textref = $firstpos }; - return $fields[0]; + push @fields, $class + ? bless (\$field, $class) + : $field; + $firstpos = $lastpos unless defined $firstpos; + $lastpos = pos $$textref; + last FIELD if @fields == $max; + next FIELD; + } + } + if ($$textref =~ /\G(.)/gcs) + { + $unkpos = pos($$textref)-1 + unless $igunk || defined $unkpos; + } + } + + if (defined $unkpos) + { + push @fields, substr($$textref, $unkpos); + $firstpos = $unkpos unless defined $firstpos; + $lastpos = length $$textref; + } + last; + } + + pos $$textref = $lastpos; + return @fields if wantarray; + + $firstpos ||= 0; + eval { substr($$textref,$firstpos,$lastpos-$firstpos)=""; + pos $$textref = $firstpos }; + return $fields[0]; } sub gen_extract_tagged # ($opentag, $closetag, $pre, \%options) { - my $ldel = $_[0]; - my $rdel = $_[1]; - my $pre = defined $_[2] ? $_[2] : '\s*'; - my %options = defined $_[3] ? %{$_[3]} : (); - my $omode = defined $options{fail} ? $options{fail} : ''; - my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}}) - : defined($options{reject}) ? $options{reject} - : '' - ; - my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}}) - : defined($options{ignore}) ? $options{ignore} - : '' - ; - - if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; } - - my $posbug = pos; - for ($ldel, $pre, $bad, $ignore) { $_ = qr/$_/ if $_ } - pos = $posbug; - - my $closure = sub - { - my $textref = defined $_[0] ? \$_[0] : \$_; - my @match = Text::Balanced::_match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore); - - return _fail(wantarray, $textref) unless @match; - return _succeed wantarray, $textref, - $match[2], $match[3]+$match[5]+$match[7], # MATCH - @match[8..9,0..1,2..7]; # REM, PRE, BITS - }; - - bless $closure, 'Text::Balanced::Extractor'; + my $ldel = $_[0]; + my $rdel = $_[1]; + my $pre = defined $_[2] ? $_[2] : '\s*'; + my %options = defined $_[3] ? %{$_[3]} : (); + my $omode = defined $options{fail} ? $options{fail} : ''; + my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}}) + : defined($options{reject}) ? $options{reject} + : '' + ; + my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}}) + : defined($options{ignore}) ? $options{ignore} + : '' + ; + + if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; } + + my $posbug = pos; + for ($ldel, $pre, $bad, $ignore) { $_ = qr/$_/ if $_ } + pos = $posbug; + + my $closure = sub + { + my $textref = defined $_[0] ? \$_[0] : \$_; + my @match = Text::Balanced::_match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore); + + return _fail(wantarray, $textref) unless @match; + return _succeed wantarray, $textref, + $match[2], $match[3]+$match[5]+$match[7], # MATCH + @match[8..9,0..1,2..7]; # REM, PRE, BITS + }; + + bless $closure, 'Text::Balanced::Extractor'; } package Text::Balanced::Extractor; -sub extract($$) # ($self, $text) +sub extract($$) # ($self, $text) { - &{$_[0]}($_[1]); + &{$_[0]}($_[1]); } package Text::Balanced::ErrorMsg; @@ -1032,83 +1041,76 @@ Text::Balanced - Extract delimited text sequences from strings. =head1 SYNOPSIS - use Text::Balanced qw ( - extract_delimited - extract_bracketed - extract_quotelike - extract_codeblock - extract_variable - extract_tagged - extract_multiple - gen_delimited_pat - gen_extract_tagged - ); + use Text::Balanced qw ( + extract_delimited + extract_bracketed + extract_quotelike + extract_codeblock + extract_variable + extract_tagged + extract_multiple + gen_delimited_pat + gen_extract_tagged + ); - # Extract the initial substring of $text that is delimited by - # two (unescaped) instances of the first character in $delim. + # Extract the initial substring of $text that is delimited by + # two (unescaped) instances of the first character in $delim. - ($extracted, $remainder) = extract_delimited($text,$delim); + ($extracted, $remainder) = extract_delimited($text,$delim); + # Extract the initial substring of $text that is bracketed + # with a delimiter(s) specified by $delim (where the string + # in $delim contains one or more of '(){}[]<>'). - # Extract the initial substring of $text that is bracketed - # with a delimiter(s) specified by $delim (where the string - # in $delim contains one or more of '(){}[]<>'). + ($extracted, $remainder) = extract_bracketed($text,$delim); - ($extracted, $remainder) = extract_bracketed($text,$delim); + # Extract the initial substring of $text that is bounded by + # an XML tag. + ($extracted, $remainder) = extract_tagged($text); - # Extract the initial substring of $text that is bounded by - # an XML tag. + # Extract the initial substring of $text that is bounded by + # a C<BEGIN>...C<END> pair. Don't allow nested C<BEGIN> tags - ($extracted, $remainder) = extract_tagged($text); + ($extracted, $remainder) = + extract_tagged($text,"BEGIN","END",undef,{bad=>["BEGIN"]}); + # Extract the initial substring of $text that represents a + # Perl "quote or quote-like operation" - # Extract the initial substring of $text that is bounded by - # a C<BEGIN>...C<END> pair. Don't allow nested C<BEGIN> tags + ($extracted, $remainder) = extract_quotelike($text); - ($extracted, $remainder) = - extract_tagged($text,"BEGIN","END",undef,{bad=>["BEGIN"]}); + # Extract the initial substring of $text that represents a block + # of Perl code, bracketed by any of character(s) specified by $delim + # (where the string $delim contains one or more of '(){}[]<>'). + ($extracted, $remainder) = extract_codeblock($text,$delim); - # Extract the initial substring of $text that represents a - # Perl "quote or quote-like operation" + # Extract the initial substrings of $text that would be extracted by + # one or more sequential applications of the specified functions + # or regular expressions - ($extracted, $remainder) = extract_quotelike($text); + @extracted = extract_multiple($text, + [ \&extract_bracketed, + \&extract_quotelike, + \&some_other_extractor_sub, + qr/[xyz]*/, + 'literal', + ]); + # Create a string representing an optimized pattern (a la Friedl) + # that matches a substring delimited by any of the specified characters + # (in this case: any type of quote or a slash) - # Extract the initial substring of $text that represents a block - # of Perl code, bracketed by any of character(s) specified by $delim - # (where the string $delim contains one or more of '(){}[]<>'). + $patstring = gen_delimited_pat(q{'"`/}); - ($extracted, $remainder) = extract_codeblock($text,$delim); + # Generate a reference to an anonymous sub that is just like extract_tagged + # but pre-compiled and optimized for a specific pair of tags, and + # consequently much faster (i.e. 3 times faster). It uses qr// for better + # performance on repeated calls. - - # Extract the initial substrings of $text that would be extracted by - # one or more sequential applications of the specified functions - # or regular expressions - - @extracted = extract_multiple($text, - [ \&extract_bracketed, - \&extract_quotelike, - \&some_other_extractor_sub, - qr/[xyz]*/, - 'literal', - ]); - -# Create a string representing an optimized pattern (a la Friedl) -# that matches a substring delimited by any of the specified characters -# (in this case: any type of quote or a slash) - - $patstring = gen_delimited_pat(q{'"`/}); - -# Generate a reference to an anonymous sub that is just like extract_tagged -# but pre-compiled and optimized for a specific pair of tags, and consequently -# much faster (i.e. 3 times faster). It uses qr// for better performance on -# repeated calls, so it only works under Perl 5.005 or later. - - $extract_head = gen_extract_tagged('<HEAD>','</HEAD>'); - - ($extracted, $remainder) = $extract_head->($text); + $extract_head = gen_extract_tagged('<HEAD>','</HEAD>'); + ($extracted, $remainder) = $extract_head->($text); =head1 DESCRIPTION @@ -1128,7 +1130,7 @@ they extract an occurrence of the substring appearing immediately at the current matching position in the string (like a C<\G>-anchored regex would). -=head2 General behaviour in list contexts +=head2 General Behaviour in List Contexts In a list context, all the subroutines return a list, the first three elements of which are always: @@ -1150,31 +1152,31 @@ extracted string). On failure, the entire string is returned. The skipped prefix (i.e. the characters before the extracted string). On failure, C<undef> is returned. -=back +=back Note that in a list context, the contents of the original input text (the first -argument) are not modified in any way. +argument) are not modified in any way. However, if the input text was passed in a variable, that variable's C<pos> value is updated to point at the first character after the extracted text. That means that in a list context the various subroutines can be used much like regular expressions. For example: - while ( $next = (extract_quotelike($text))[0] ) - { - # process next quote-like (in $next) - } + while ( $next = (extract_quotelike($text))[0] ) + { + # process next quote-like (in $next) + } -=head2 General behaviour in scalar and void contexts +=head2 General Behaviour in Scalar and Void Contexts In a scalar context, the extracted string is returned, having first been removed from the input text. Thus, the following code also processes each quote-like operation, but actually removes them from $text: - while ( $next = extract_quotelike($text) ) - { - # process next quote-like (in $next) - } + while ( $next = extract_quotelike($text) ) + { + # process next quote-like (in $next) + } Note that if the input text is a read-only string (i.e. a literal), no attempt is made to remove the extracted text. @@ -1183,7 +1185,7 @@ In a void context the behaviour of the extraction subroutines is exactly the same as in a scalar context, except (of course) that the extracted substring is not returned. -=head2 A note about prefixes +=head2 A Note About Prefixes Prefix patterns are matched without any trailing modifiers (C</gimsox> etc.) This can bite you if you're expecting a prefix specification like @@ -1194,19 +1196,23 @@ pattern will only succeed if the <H1> tag is on the current line, since To overcome this limitation, you need to turn on /s matching within the prefix pattern, using the C<(?s)> directive: '(?s).*?(?=<H1>)' -=head2 C<extract_delimited> +=head2 Functions + +=over 4 + +=item C<extract_delimited> The C<extract_delimited> function formalizes the common idiom of extracting a single-character-delimited substring from the start of a string. For example, to extract a single-quote delimited string, the following code is typically used: - ($remainder = $text) =~ s/\A('(\\.|[^'])*')//s; - $extracted = $1; + ($remainder = $text) =~ s/\A('(\\.|[^'])*')//s; + $extracted = $1; but with C<extract_delimited> it can be simplified to: - ($extracted,$remainder) = extract_delimited($text, "'"); + ($extracted,$remainder) = extract_delimited($text, "'"); C<extract_delimited> takes up to four scalars (the input text, the delimiters, a prefix pattern to be skipped, and any escape characters) @@ -1240,42 +1246,42 @@ removed from the beginning of the first argument. Examples: - # Remove a single-quoted substring from the very beginning of $text: + # Remove a single-quoted substring from the very beginning of $text: - $substring = extract_delimited($text, "'", ''); + $substring = extract_delimited($text, "'", ''); - # Remove a single-quoted Pascalish substring (i.e. one in which - # doubling the quote character escapes it) from the very - # beginning of $text: + # Remove a single-quoted Pascalish substring (i.e. one in which + # doubling the quote character escapes it) from the very + # beginning of $text: - $substring = extract_delimited($text, "'", '', "'"); + $substring = extract_delimited($text, "'", '', "'"); - # Extract a single- or double- quoted substring from the - # beginning of $text, optionally after some whitespace - # (note the list context to protect $text from modification): + # Extract a single- or double- quoted substring from the + # beginning of $text, optionally after some whitespace + # (note the list context to protect $text from modification): - ($substring) = extract_delimited $text, q{"'}; + ($substring) = extract_delimited $text, q{"'}; - # Delete the substring delimited by the first '/' in $text: + # Delete the substring delimited by the first '/' in $text: - $text = join '', (extract_delimited($text,'/','[^/]*')[2,1]; + $text = join '', (extract_delimited($text,'/','[^/]*')[2,1]; Note that this last example is I<not> the same as deleting the first quote-like pattern. For instance, if C<$text> contained the string: - "if ('./cmd' =~ m/$UNIXCMD/s) { $cmd = $1; }" - + "if ('./cmd' =~ m/$UNIXCMD/s) { $cmd = $1; }" + then after the deletion it would contain: - "if ('.$UNIXCMD/s) { $cmd = $1; }" + "if ('.$UNIXCMD/s) { $cmd = $1; }" not: - "if ('./cmd' =~ ms) { $cmd = $1; }" - + "if ('./cmd' =~ ms) { $cmd = $1; }" + See L<"extract_quotelike"> for a (partial) solution to this problem. -=head2 C<extract_bracketed> +=item C<extract_bracketed> Like C<"extract_delimited">, the C<extract_bracketed> function takes up to three optional scalar arguments: a string to extract from, a delimiter @@ -1307,15 +1313,15 @@ balanced and correctly nested within the substring, and any other kind of For example, given the string: - $text = "{ an '[irregularly :-(] {} parenthesized >:-)' string }"; + $text = "{ an '[irregularly :-(] {} parenthesized >:-)' string }"; then a call to C<extract_bracketed> in a list context: - @result = extract_bracketed( $text, '{}' ); + @result = extract_bracketed( $text, '{}' ); would return: - ( "{ an '[irregularly :-(] {} parenthesized >:-)' string }" , "" , "" ) + ( "{ an '[irregularly :-(] {} parenthesized >:-)' string }" , "" , "" ) since both sets of C<'{..}'> brackets are properly nested and evenly balanced. (In a scalar context just the first element of the array would be returned. In @@ -1323,18 +1329,18 @@ a void context, C<$text> would be replaced by an empty string.) Likewise the call in: - @result = extract_bracketed( $text, '{[' ); + @result = extract_bracketed( $text, '{[' ); would return the same result, since all sets of both types of specified delimiter brackets are correctly nested and balanced. However, the call in: - @result = extract_bracketed( $text, '{([<' ); + @result = extract_bracketed( $text, '{([<' ); would fail, returning: - ( undef , "{ an '[irregularly :-(] {} parenthesized >:-)' string }" ); + ( undef , "{ an '[irregularly :-(] {} parenthesized >:-)' string }" ); because the embedded pairs of C<'(..)'>s and C<'[..]'>s are "cross-nested" and the embedded C<'E<gt>'> is unbalanced. (In a scalar context, this call would @@ -1348,37 +1354,37 @@ However, if a particular species of quote character is included in the delimiter specification, then that type of quote will be correctly handled. for example, if C<$text> is: - $text = '<A HREF=">>>>">link</A>'; + $text = '<A HREF=">>>>">link</A>'; then - @result = extract_bracketed( $text, '<">' ); + @result = extract_bracketed( $text, '<">' ); returns: - ( '<A HREF=">>>>">', 'link</A>', "" ) + ( '<A HREF=">>>>">', 'link</A>', "" ) as expected. Without the specification of C<"> as an embedded quoter: - @result = extract_bracketed( $text, '<>' ); + @result = extract_bracketed( $text, '<>' ); the result would be: - ( '<A HREF=">', '>>>">link</A>', "" ) + ( '<A HREF=">', '>>>">link</A>', "" ) In addition to the quote delimiters C<'>, C<">, and C<`>, full Perl quote-like quoting (i.e. q{string}, qq{string}, etc) can be specified by including the letter 'q' as a delimiter. Hence: - @result = extract_bracketed( $text, '<q>' ); + @result = extract_bracketed( $text, '<q>' ); would correctly match something like this: - $text = '<leftop: conj /and/ conj>'; + $text = '<leftop: conj /and/ conj>'; See also: C<"extract_quotelike"> and C<"extract_codeblock">. -=head2 C<extract_variable> +=item C<extract_variable> C<extract_variable> extracts any valid Perl variable or variable-involved expression, including scalars, arrays, hashes, array @@ -1429,11 +1435,10 @@ failure. In addition, the original input text has the returned substring In a void context, the input text just has the matched substring (and any specified prefix) removed. - -=head2 C<extract_tagged> +=item C<extract_tagged> C<extract_tagged> extracts and segments text between (balanced) -specified tags. +specified tags. The subroutine takes up to five optional arguments: @@ -1451,12 +1456,12 @@ that matches any standard XML tag is used. =item 3. -A string specifying a pattern to be matched at the closing tag. +A string specifying a pattern to be matched at the closing tag. If the pattern string is omitted (or C<undef>) then the closing tag is constructed by inserting a C</> after any leading bracket characters in the actual opening tag that was matched (I<not> the pattern that matched the tag). For example, if the opening tag pattern -is specified as C<'{{\w+}}'> and actually matched the opening tag +is specified as C<'{{\w+}}'> and actually matched the opening tag C<"{{DATA}}">, then the constructed closing tag would be C<"{{/DATA}}">. =item 4. @@ -1487,7 +1492,7 @@ an HTML link (which should not contain nested links) use: =item C<ignore =E<gt> $listref> The list reference contains one or more strings specifying patterns -that are I<not> be be treated as nested tags within the tagged text +that are I<not> to be treated as nested tags within the tagged text (even if they would match the start tag pattern). For example, to extract an arbitrary XML tag, but ignore "empty" elements: @@ -1508,7 +1513,7 @@ C<extract_tagged> returns the complete text up to the point of failure. If the string is "PARA", C<extract_tagged> returns only the first paragraph after the tag (up to the first line that is either empty or contains only whitespace characters). -If the string is "", the the default behaviour (i.e. failure) is reinstated. +If the string is "", the default behaviour (i.e. failure) is reinstated. For example, suppose the start tag "/para" introduces a paragraph, which then continues until the next "/endpara" tag or until another "/para" tag is @@ -1575,9 +1580,7 @@ text has the returned substring (and any prefix) removed from it. In a void context, the input text just has the matched substring (and any specified prefix) removed. -=head2 C<gen_extract_tagged> - -(Note: This subroutine is only available under Perl5.005) +=item C<gen_extract_tagged> C<gen_extract_tagged> generates a new anonymous subroutine which extracts text between (balanced) specified tags. In other words, @@ -1589,7 +1592,7 @@ C<gen_extract_tagged>, is that those generated subroutines: =over 4 -=item * +=item * do not have to reparse tag specification or parsing options every time they are called (whereas C<extract_tagged> has to effectively rebuild @@ -1598,7 +1601,7 @@ its tag parser on every call); =item * make use of the new qr// construct to pre-compile the regexes they use -(whereas C<extract_tagged> uses standard string variable interpolation +(whereas C<extract_tagged> uses standard string variable interpolation to create tag-matching patterns). =back @@ -1618,16 +1621,14 @@ equivalent to: return $extractor->($text); } -(although C<extract_tagged> is not currently implemented that way, in order -to preserve pre-5.005 compatibility). +(although C<extract_tagged> is not currently implemented that way). -Using C<gen_extract_tagged> to create extraction functions for specific tags +Using C<gen_extract_tagged> to create extraction functions for specific tags is a good idea if those functions are going to be called more than once, since their performance is typically twice as good as the more general-purpose C<extract_tagged>. - -=head2 C<extract_quotelike> +=item C<extract_quotelike> C<extract_quotelike> attempts to recognize, extract, and segment any one of the various Perl quotes and quotelike operators (see @@ -1636,7 +1637,7 @@ delimiters (for the quotelike operators), and trailing modifiers are all caught. For example, in: extract_quotelike 'q # an octothorpe: \# (not the end of the q!) #' - + extract_quotelike ' "You said, \"Use sed\"." ' extract_quotelike ' s{([A-Z]{1,8}\.[A-Z]{3})} /\L$1\E/; ' @@ -1664,7 +1665,7 @@ will be extracted as if it were: This behaviour is identical to that of the actual compiler. C<extract_quotelike> takes two arguments: the text to be processed and -a prefix to be matched at the very beginning of the text. If no prefix +a prefix to be matched at the very beginning of the text. If no prefix is specified, optional whitespace is the default. If no text is given, C<$_> is used. @@ -1710,7 +1711,7 @@ the left delimiter of the second block of the operation =item [8] -the text of the second block of the operation +the text of the second block of the operation (that is, the replacement of a substitution or the translation list of a translation), @@ -1757,7 +1758,7 @@ Examples: print "$op is not a pattern matching operation\n"; } -=head2 C<extract_quotelike> and "here documents" +=item C<extract_quotelike> C<extract_quotelike> can successfully extract "here documents" from an input string, but with an important caveat in list contexts. @@ -1842,7 +1843,7 @@ you can pass the input variable as an interpolated literal: $quotelike = extract_quotelike("$var"); -=head2 C<extract_codeblock> +=item C<extract_codeblock> C<extract_codeblock> attempts to recognize and extract a balanced bracket delimited substring that may contain unbalanced brackets @@ -1861,7 +1862,7 @@ Omitting the third argument (prefix argument) implies optional whitespace at the Omitting the fourth argument (outermost delimiter brackets) indicates that the value of the second argument is to be used for the outermost delimiters. -Once the prefix an dthe outermost opening delimiter bracket have been +Once the prefix and the outermost opening delimiter bracket have been recognized, code blocks are extracted by stepping through the input text and trying the following alternatives in sequence: @@ -1933,9 +1934,9 @@ S<C<extract_codeblock($text, '{}', undef, 'E<lt>E<gt>')>> the '>' character is only treated as a delimited at the outermost level of the code block, so the directive is parsed correctly. -=head2 C<extract_multiple> +=item C<extract_multiple> -The C<extract_multiple> subroutine takes a string to be processed and a +The C<extract_multiple> subroutine takes a string to be processed and a list of extractors (subroutines or regular expressions) to apply to that string. In an array context C<extract_multiple> returns an array of substrings @@ -1947,7 +1948,7 @@ extracted substring removed from it. In all contexts C<extract_multiple> starts at the current C<pos> of the string, and sets that C<pos> appropriately after it matches. -Hence, the aim of of a call to C<extract_multiple> in a list context +Hence, the aim of a call to C<extract_multiple> in a list context is to split the processed string into as many non-overlapping fields as possible, by repeatedly applying each of the specified extractors to the remainder of the string. Thus C<extract_multiple> is @@ -1982,11 +1983,11 @@ An number specifying the maximum number of fields to return. If this argument is omitted (or C<undef>), split continues as long as possible. If the third argument is I<N>, then extraction continues until I<N> fields -have been successfully extracted, or until the string has been completely +have been successfully extracted, or until the string has been completely processed. -Note that in scalar and void contexts the value of this argument is -automatically reset to 1 (under C<-w>, a warning is issued if the argument +Note that in scalar and void contexts the value of this argument is +automatically reset to 1 (under C<-w>, a warning is issued if the argument has to be reset). =item 4. @@ -2026,7 +2027,7 @@ return value of the extractor will be blessed. If an extractor returns a defined value, that value is immediately treated as the next extracted field and pushed onto the list of fields. If the extractor was specified in a hash reference, the field is also -blessed into the appropriate class, +blessed into the appropriate class, If the extractor fails to match (in the case of a regex extractor), or returns an empty list or an undefined value (in the case of a subroutine extractor), it is assumed to have failed to extract. @@ -2080,7 +2081,7 @@ If you wanted the commas preserved as separate fields (i.e. like split does if your split pattern has capturing parentheses), you would just make the last parameter undefined (or remove it). -=head2 C<gen_delimited_pat> +=item C<gen_delimited_pat> The C<gen_delimited_pat> subroutine takes a single (string) argument and > builds a Friedl-style optimized regex that matches a string delimited @@ -2119,11 +2120,12 @@ If more delimiters than escape chars are specified, the last escape char is used for the remaining delimiters. If no escape char is specified for a given specified delimiter, '\' is used. -=head2 C<delimited_pat> +=item C<delimited_pat> Note that C<gen_delimited_pat> was previously called C<delimited_pat>. That name may still be used, but is now deprecated. - + +=back =head1 DIAGNOSTICS @@ -2170,7 +2172,7 @@ a closing bracket where none was expected. =item C<Unmatched opening bracket(s): "%s"> -C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> ran +C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> ran out of characters in the text before closing one or more levels of nested brackets. @@ -2257,25 +2259,125 @@ to match the original opening tag (and the failure mode was not =back -=head1 AUTHOR +=head1 EXPORTS -Damian Conway (damian@conway.org) +The following symbols are, or can be, exported by this module: -=head1 BUGS AND IRRITATIONS +=over 4 + +=item Default Exports + +I<None>. + +=item Optional Exports + +C<extract_delimited>, +C<extract_bracketed>, +C<extract_quotelike>, +C<extract_codeblock>, +C<extract_variable>, +C<extract_tagged>, +C<extract_multiple>, +C<gen_delimited_pat>, +C<gen_extract_tagged>, +C<delimited_pat>. + +=item Export Tags + +=over 4 + +=item C<:ALL> + +C<extract_delimited>, +C<extract_bracketed>, +C<extract_quotelike>, +C<extract_codeblock>, +C<extract_variable>, +C<extract_tagged>, +C<extract_multiple>, +C<gen_delimited_pat>, +C<gen_extract_tagged>, +C<delimited_pat>. + +=back + +=back + +=head1 KNOWN BUGS + +See L<https://rt.cpan.org/Dist/Display.html?Status=Active&Queue=Text-Balanced>. + +=head1 FEEDBACK + +Patches, bug reports, suggestions or any other feedback is welcome. + +Patches can be sent as GitHub pull requests at +L<https://github.com/steve-m-hay/Text-Balanced/pulls>. + +Bug reports and suggestions can be made on the CPAN Request Tracker at +L<https://rt.cpan.org/Public/Bug/Report.html?Queue=Text-Balanced>. + +Currently active requests on the CPAN Request Tracker can be viewed at +L<https://rt.cpan.org/Public/Dist/Display.html?Status=Active;Queue=Text-Balanced>. -There are undoubtedly serious bugs lurking somewhere in this code, if -only because parts of it give the impression of understanding a great deal -more about Perl than they really do. +Please test this distribution. See CPAN Testers Reports at +L<https://www.cpantesters.org/> for details of how to get involved. -Bug reports and other feedback are most welcome. +Previous test results on CPAN Testers Reports can be viewed at +L<https://www.cpantesters.org/distro/T/Text-Balanced.html>. + +Please rate this distribution on CPAN Ratings at +L<https://cpanratings.perl.org/rate/?distribution=Text-Balanced>. + +=head1 AVAILABILITY + +The latest version of this module is available from CPAN (see +L<perlmodlib/"CPAN"> for details) at + +L<https://metacpan.org/release/Text-Balanced> or + +L<https://www.cpan.org/authors/id/S/SH/SHAY/> or + +L<https://www.cpan.org/modules/by-module/Text/>. + +The latest source code is available from GitHub at +L<https://github.com/steve-m-hay/Text-Balanced>. + +=head1 INSTALLATION + +See the F<INSTALL> file. + +=head1 AUTHOR + +Damian Conway E<lt>L<damian@conway.org|mailto:damian@conway.org>E<gt>. + +Steve Hay E<lt>L<shay@cpan.org|mailto:shay@cpan.org>E<gt> is now maintaining +Text::Balanced as of version 2.03. =head1 COPYRIGHT -Copyright 1997 - 2001 Damian Conway. All Rights Reserved. +Copyright (C) 1997-2001 Damian Conway. All rights reserved. + +Copyright (C) 2009 Adam Kennedy. + +Copyright (C) 2015, 2020 Steve Hay. All rights reserved. + +=head1 LICENCE + +This module is free software; you can redistribute it and/or modify it under the +same terms as Perl itself, i.e. under the terms of either the GNU General Public +License or the Artistic License, as specified in the F<LICENCE> file. + +=head1 VERSION + +Version 2.04 + +=head1 DATE + +11 Dec 2020 -Some (minor) parts copyright 2009 Adam Kennedy. +=head1 HISTORY -This module is free software. It may be used, redistributed -and/or modified under the same terms as Perl itself. +See the F<Changes> file. =cut diff --git a/cpan/Text-Balanced/t/01_compile.t b/cpan/Text-Balanced/t/01_compile.t index 77c1099995..a6e91911c7 100644 --- a/cpan/Text-Balanced/t/01_compile.t +++ b/cpan/Text-Balanced/t/01_compile.t @@ -1,10 +1,9 @@ #!/usr/bin/perl +use 5.008001; + use strict; -BEGIN { - $| = 1; - $^W = 1; -} +use warnings; use Test::More tests => 1; diff --git a/cpan/Text-Balanced/t/02_extbrk.t b/cpan/Text-Balanced/t/02_extbrk.t index a36025ddb0..5da792f1f0 100644 --- a/cpan/Text-Balanced/t/02_extbrk.t +++ b/cpan/Text-Balanced/t/02_extbrk.t @@ -1,52 +1,60 @@ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' +use 5.008001; + +use strict; +use warnings; + ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +my $loaded = 0; BEGIN { $| = 1; print "1..19\n"; } END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( extract_bracketed ); $loaded = 1; print "ok 1\n"; -$count=2; +my $count=2; use vars qw( $DEBUG ); sub debug { print "\t>>>",@_ if $DEBUG } ######################### End of black magic. +## no critic (BuiltinFunctions::ProhibitStringyEval) -$cmd = "print"; -$neg = 0; +my $cmd = "print"; +my $neg = 0; +my $str; while (defined($str = <DATA>)) { - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; - - $var = eval "() = $cmd"; - debug "\t list got: [$var]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str),1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; - - pos $str = 0; - $var = eval $cmd; - $var = "<undef>" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; + + my $var = eval "() = $cmd"; + debug "\t list got: [$var]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str),1) eq ';')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; + + pos $str = 0; + $var = eval $cmd; + $var = "<undef>" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; } __DATA__ diff --git a/cpan/Text-Balanced/t/03_extcbk.t b/cpan/Text-Balanced/t/03_extcbk.t index 83081ae28d..398d2771ba 100644 --- a/cpan/Text-Balanced/t/03_extcbk.t +++ b/cpan/Text-Balanced/t/03_extcbk.t @@ -1,53 +1,61 @@ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' +use 5.008001; + +use strict; +use warnings; + ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +my $loaded = 0; BEGIN { $| = 1; print "1..41\n"; } END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( extract_codeblock ); $loaded = 1; print "ok 1\n"; -$count=2; +my $count=2; use vars qw( $DEBUG ); sub debug { print "\t>>>",@_ if $DEBUG } ######################### End of black magic. +## no critic (BuiltinFunctions::ProhibitStringyEval) -$cmd = "print"; -$neg = 0; +my $cmd = "print"; +my $neg = 0; +my $str; while (defined($str = <DATA>)) { - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; - - my @res; - $var = eval "\@res = $cmd"; - debug "\t Failed: $@ at " . $@+0 .")" if $@; - debug "\t list got: [" . join("|", map {defined $_ ? $_ : '<undef>'} @res) . "]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print "\n"; - - pos $str = 0; - $var = eval $cmd; - $var = "<undef>" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; + + my @res; + my $var = eval "\@res = $cmd"; + debug "\t Failed: $@ at " . $@+0 .")" if $@; + debug "\t list got: [" . join("|", map {defined $_ ? $_ : '<undef>'} @res) . "]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; + print "ok ", $count++; + print "\n"; + + pos $str = 0; + $var = eval $cmd; + $var = "<undef>" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; } __DATA__ diff --git a/cpan/Text-Balanced/t/04_extdel.t b/cpan/Text-Balanced/t/04_extdel.t index c5ca88eebf..b2f94cf51c 100644 --- a/cpan/Text-Balanced/t/04_extdel.t +++ b/cpan/Text-Balanced/t/04_extdel.t @@ -1,52 +1,60 @@ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' +use 5.008001; + +use strict; +use warnings; + ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +my $loaded = 0; BEGIN { $| = 1; print "1..45\n"; } END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( extract_delimited ); $loaded = 1; print "ok 1\n"; -$count=2; +my $count=2; use vars qw( $DEBUG ); sub debug { print "\t>>>",@_ if $DEBUG } ######################### End of black magic. +## no critic (BuiltinFunctions::ProhibitStringyEval) -$cmd = "print"; -$neg = 0; +my $cmd = "print"; +my $neg = 0; +my $str; while (defined($str = <DATA>)) { - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; - $var = eval "() = $cmd"; - debug "\t list got: [$var]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + my $var = eval "() = $cmd"; + debug "\t list got: [$var]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; - pos $str = 0; - $var = eval $cmd; - $var = "<undef>" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + pos $str = 0; + $var = eval $cmd; + $var = "<undef>" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; } __DATA__ diff --git a/cpan/Text-Balanced/t/05_extmul.t b/cpan/Text-Balanced/t/05_extmul.t index 2ac1b19ffd..9a9711b4f6 100644 --- a/cpan/Text-Balanced/t/05_extmul.t +++ b/cpan/Text-Balanced/t/05_extmul.t @@ -1,17 +1,23 @@ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' +use 5.008001; + +use strict; +use warnings; + ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +my $loaded = 0; BEGIN { $| = 1; print "1..86\n"; } END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( :ALL ); $loaded = 1; print "ok 1\n"; -$count=2; +my $count=2; use vars qw( $DEBUG ); sub debug { print "\t>>>",@_ if $DEBUG } @@ -19,62 +25,62 @@ sub debug { print "\t>>>",@_ if $DEBUG } sub expect { - local $^W; - my ($l1, $l2) = @_; - - if (@$l1 != @$l2) - { - print "\@l1: ", join(", ", @$l1), "\n"; - print "\@l2: ", join(", ", @$l2), "\n"; - print "not "; - } - else - { - for (my $i = 0; $i < @$l1; $i++) - { - if ($l1->[$i] ne $l2->[$i]) - { - print "field $i: '$l1->[$i]' ne '$l2->[$i]'\n"; - print "not "; - last; - } - } - } - - print "ok $count\n"; - $count++; + local $^W; + my ($l1, $l2) = @_; + + if (@$l1 != @$l2) + { + print "\@l1: ", join(", ", @$l1), "\n"; + print "\@l2: ", join(", ", @$l2), "\n"; + print "not "; + } + else + { + for (my $i = 0; $i < @$l1; $i++) + { + if ($l1->[$i] ne $l2->[$i]) + { + print "field $i: '$l1->[$i]' ne '$l2->[$i]'\n"; + print "not "; + last; + } + } + } + + print "ok $count\n"; + $count++; } sub divide { - my ($text, @index) = @_; - my @bits = (); - unshift @index, 0; - push @index, length($text); - for ( my $i= 0; $i < $#index; $i++) - { - push @bits, substr($text, $index[$i], $index[$i+1]-$index[$i]); - } - pop @bits; - return @bits; + my ($text, @index) = @_; + my @bits = (); + unshift @index, 0; + push @index, length($text); + for ( my $i= 0; $i < $#index; $i++) + { + push @bits, substr($text, $index[$i], $index[$i+1]-$index[$i]); + } + pop @bits; + return @bits; } -$stdtext1 = q{$var = do {"val" && $val;};}; +my $stdtext1 = q{$var = do {"val" && $val;};}; # TESTS 2-4 -$text = $stdtext1; -expect [ extract_multiple($text,undef,1) ], - [ divide $stdtext1 => 4 ]; +my $text = $stdtext1; +expect [ extract_multiple($text,undef,1) ], + [ divide $stdtext1 => 4 ]; expect [ pos $text], [ 4 ]; expect [ $text ], [ $stdtext1 ]; # TESTS 5-7 $text = $stdtext1; -expect [ scalar extract_multiple($text,undef,1) ], - [ divide $stdtext1 => 4 ]; +expect [ scalar extract_multiple($text,undef,1) ], + [ divide $stdtext1 => 4 ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext1,4) ]; @@ -82,16 +88,16 @@ expect [ $text ], [ substr($stdtext1,4) ]; # TESTS 8-10 $text = $stdtext1; -expect [ extract_multiple($text,undef,2) ], - [ divide($stdtext1 => 4, 10) ]; +expect [ extract_multiple($text,undef,2) ], + [ divide($stdtext1 => 4, 10) ]; expect [ pos $text], [ 10 ]; expect [ $text ], [ $stdtext1 ]; # TESTS 11-13 $text = $stdtext1; -expect [ eval{local$^W;scalar extract_multiple($text,undef,2)} ], - [ substr($stdtext1,0,4) ]; +expect [ eval{local$^W;scalar extract_multiple($text,undef,2)} ], + [ substr($stdtext1,0,4) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext1,4) ]; @@ -99,16 +105,16 @@ expect [ $text ], [ substr($stdtext1,4) ]; # TESTS 14-16 $text = $stdtext1; -expect [ extract_multiple($text,undef,3) ], - [ divide($stdtext1 => 4, 10, 26) ]; +expect [ extract_multiple($text,undef,3) ], + [ divide($stdtext1 => 4, 10, 26) ]; expect [ pos $text], [ 26 ]; expect [ $text ], [ $stdtext1 ]; # TESTS 17-19 $text = $stdtext1; -expect [ eval{local$^W;scalar extract_multiple($text,undef,3)} ], - [ substr($stdtext1,0,4) ]; +expect [ eval{local$^W;scalar extract_multiple($text,undef,3)} ], + [ substr($stdtext1,0,4) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext1,4) ]; @@ -116,16 +122,16 @@ expect [ $text ], [ substr($stdtext1,4) ]; # TESTS 20-22 $text = $stdtext1; -expect [ extract_multiple($text,undef,4) ], - [ divide($stdtext1 => 4, 10, 26, 27) ]; +expect [ extract_multiple($text,undef,4) ], + [ divide($stdtext1 => 4, 10, 26, 27) ]; expect [ pos $text], [ 27 ]; expect [ $text ], [ $stdtext1 ]; # TESTS 23-25 $text = $stdtext1; -expect [ eval{local$^W;scalar extract_multiple($text,undef,4)} ], - [ substr($stdtext1,0,4) ]; +expect [ eval{local$^W;scalar extract_multiple($text,undef,4)} ], + [ substr($stdtext1,0,4) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext1,4) ]; @@ -133,8 +139,8 @@ expect [ $text ], [ substr($stdtext1,4) ]; # TESTS 26-28 $text = $stdtext1; -expect [ extract_multiple($text,undef,5) ], - [ divide($stdtext1 => 4, 10, 26, 27) ]; +expect [ extract_multiple($text,undef,5) ], + [ divide($stdtext1 => 4, 10, 26, 27) ]; expect [ pos $text], [ 27 ]; expect [ $text ], [ $stdtext1 ]; @@ -142,8 +148,8 @@ expect [ $text ], [ $stdtext1 ]; # TESTS 29-31 $text = $stdtext1; -expect [ eval{local$^W;scalar extract_multiple($text,undef,5)} ], - [ substr($stdtext1,0,4) ]; +expect [ eval{local$^W;scalar extract_multiple($text,undef,5)} ], + [ substr($stdtext1,0,4) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext1,4) ]; @@ -151,19 +157,19 @@ expect [ $text ], [ substr($stdtext1,4) ]; # TESTS 32-34 -$stdtext2 = q{$var = "val" && (1,2,3);}; +my $stdtext2 = q{$var = "val" && (1,2,3);}; $text = $stdtext2; -expect [ extract_multiple($text) ], - [ divide($stdtext2 => 4, 7, 12, 24) ]; +expect [ extract_multiple($text) ], + [ divide($stdtext2 => 4, 7, 12, 24) ]; expect [ pos $text], [ 24 ]; expect [ $text ], [ $stdtext2 ]; # TESTS 35-37 $text = $stdtext2; -expect [ scalar extract_multiple($text) ], - [ substr($stdtext2,0,4) ]; +expect [ scalar extract_multiple($text) ], + [ substr($stdtext2,0,4) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext2,4) ]; @@ -171,16 +177,16 @@ expect [ $text ], [ substr($stdtext2,4) ]; # TESTS 38-40 $text = $stdtext2; -expect [ extract_multiple($text,[\&extract_bracketed]) ], - [ substr($stdtext2,0,16), substr($stdtext2,16,7), substr($stdtext2,23) ]; +expect [ extract_multiple($text,[\&extract_bracketed]) ], + [ substr($stdtext2,0,16), substr($stdtext2,16,7), substr($stdtext2,23) ]; expect [ pos $text], [ 24 ]; expect [ $text ], [ $stdtext2 ]; # TESTS 41-43 $text = $stdtext2; -expect [ scalar extract_multiple($text,[\&extract_bracketed]) ], - [ substr($stdtext2,0,16) ]; +expect [ scalar extract_multiple($text,[\&extract_bracketed]) ], + [ substr($stdtext2,0,16) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext2,15) ]; @@ -188,16 +194,16 @@ expect [ $text ], [ substr($stdtext2,15) ]; # TESTS 44-46 $text = $stdtext2; -expect [ extract_multiple($text,[\&extract_variable]) ], - [ substr($stdtext2,0,4), substr($stdtext2,4) ]; +expect [ extract_multiple($text,[\&extract_variable]) ], + [ substr($stdtext2,0,4), substr($stdtext2,4) ]; expect [ pos $text], [ length($text) ]; expect [ $text ], [ $stdtext2 ]; # TESTS 47-49 $text = $stdtext2; -expect [ scalar extract_multiple($text,[\&extract_variable]) ], - [ substr($stdtext2,0,4) ]; +expect [ scalar extract_multiple($text,[\&extract_variable]) ], + [ substr($stdtext2,0,4) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext2,4) ]; @@ -205,16 +211,16 @@ expect [ $text ], [ substr($stdtext2,4) ]; # TESTS 50-52 $text = $stdtext2; -expect [ extract_multiple($text,[\&extract_quotelike]) ], - [ substr($stdtext2,0,7), substr($stdtext2,7,5), substr($stdtext2,12) ]; +expect [ extract_multiple($text,[\&extract_quotelike]) ], + [ substr($stdtext2,0,7), substr($stdtext2,7,5), substr($stdtext2,12) ]; expect [ pos $text], [ length($text) ]; expect [ $text ], [ $stdtext2 ]; # TESTS 53-55 $text = $stdtext2; -expect [ scalar extract_multiple($text,[\&extract_quotelike]) ], - [ substr($stdtext2,0,7) ]; +expect [ scalar extract_multiple($text,[\&extract_quotelike]) ], + [ substr($stdtext2,0,7) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext2,6) ]; @@ -222,16 +228,16 @@ expect [ $text ], [ substr($stdtext2,6) ]; # TESTS 56-58 $text = $stdtext2; -expect [ extract_multiple($text,[\&extract_quotelike],2,1) ], - [ substr($stdtext2,7,5) ]; +expect [ extract_multiple($text,[\&extract_quotelike],2,1) ], + [ substr($stdtext2,7,5) ]; expect [ pos $text], [ 23 ]; expect [ $text ], [ $stdtext2 ]; # TESTS 59-61 $text = $stdtext2; -expect [ eval{local$^W;scalar extract_multiple($text,[\&extract_quotelike],2,1)} ], - [ substr($stdtext2,7,5) ]; +expect [ eval{local$^W;scalar extract_multiple($text,[\&extract_quotelike],2,1)} ], + [ substr($stdtext2,7,5) ]; expect [ pos $text], [ 6 ]; expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; @@ -239,16 +245,16 @@ expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; # TESTS 62-64 $text = $stdtext2; -expect [ extract_multiple($text,[\&extract_quotelike],1,1) ], - [ substr($stdtext2,7,5) ]; +expect [ extract_multiple($text,[\&extract_quotelike],1,1) ], + [ substr($stdtext2,7,5) ]; expect [ pos $text], [ 12 ]; expect [ $text ], [ $stdtext2 ]; # TESTS 65-67 $text = $stdtext2; -expect [ scalar extract_multiple($text,[\&extract_quotelike],1,1) ], - [ substr($stdtext2,7,5) ]; +expect [ scalar extract_multiple($text,[\&extract_quotelike],1,1) ], + [ substr($stdtext2,7,5) ]; expect [ pos $text], [ 6 ]; expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; @@ -257,8 +263,8 @@ expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; my $stdtext3 = "a,b,c"; $_ = $stdtext3; -expect [ extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], - [ divide($stdtext3 => 1,2,3,4,5) ]; +expect [ extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], + [ divide($stdtext3 => 1,2,3,4,5) ]; expect [ pos ], [ 5 ]; expect [ $_ ], [ $stdtext3 ]; @@ -266,8 +272,8 @@ expect [ $_ ], [ $stdtext3 ]; # TESTS 71-73 $_ = $stdtext3; -expect [ scalar extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], - [ divide($stdtext3 => 1) ]; +expect [ scalar extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], + [ divide($stdtext3 => 1) ]; expect [ pos ], [ 0 ]; expect [ $_ ], [ substr($stdtext3,1) ]; @@ -276,8 +282,8 @@ expect [ $_ ], [ substr($stdtext3,1) ]; # TESTS 74-76 $_ = $stdtext3; -expect [ extract_multiple(undef, [ qr/\G[a-z]/ ]) ], - [ divide($stdtext3 => 1,2,3,4,5) ]; +expect [ extract_multiple(undef, [ qr/\G[a-z]/ ]) ], + [ divide($stdtext3 => 1,2,3,4,5) ]; expect [ pos ], [ 5 ]; expect [ $_ ], [ $stdtext3 ]; @@ -285,8 +291,8 @@ expect [ $_ ], [ $stdtext3 ]; # TESTS 77-79 $_ = $stdtext3; -expect [ scalar extract_multiple(undef, [ qr/\G[a-z]/ ]) ], - [ divide($stdtext3 => 1) ]; +expect [ scalar extract_multiple(undef, [ qr/\G[a-z]/ ]) ], + [ divide($stdtext3 => 1) ]; expect [ pos ], [ 0 ]; expect [ $_ ], [ substr($stdtext3,1) ]; @@ -295,8 +301,8 @@ expect [ $_ ], [ substr($stdtext3,1) ]; # TESTS 80-82 $_ = $stdtext3; -expect [ extract_multiple(undef, [ q/([a-z]),?/ ]) ], - [ qw(a b c) ]; +expect [ extract_multiple(undef, [ q/([a-z]),?/ ]) ], + [ qw(a b c) ]; expect [ pos ], [ 5 ]; expect [ $_ ], [ $stdtext3 ]; @@ -304,8 +310,8 @@ expect [ $_ ], [ $stdtext3 ]; # TESTS 83-85 $_ = $stdtext3; -expect [ scalar extract_multiple(undef, [ q/([a-z]),?/ ]) ], - [ divide($stdtext3 => 1) ]; +expect [ scalar extract_multiple(undef, [ q/([a-z]),?/ ]) ], + [ divide($stdtext3 => 1) ]; expect [ pos ], [ 0 ]; expect [ $_ ], [ substr($stdtext3,2) ]; @@ -315,5 +321,5 @@ expect [ $_ ], [ substr($stdtext3,2) ]; # Fails in Text-Balanced-1.95 with result ['1 ', '""', '1234'] $_ = q{ ""1234}; -expect [ extract_multiple(undef, [\&extract_quotelike]) ], - [ ' ', '""', '1234' ]; +expect [ extract_multiple(undef, [\&extract_quotelike]) ], + [ ' ', '""', '1234' ]; diff --git a/cpan/Text-Balanced/t/06_extqlk.t b/cpan/Text-Balanced/t/06_extqlk.t index 6badc0ee18..e32ca7d130 100644 --- a/cpan/Text-Balanced/t/06_extqlk.t +++ b/cpan/Text-Balanced/t/06_extqlk.t @@ -2,17 +2,23 @@ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' +use 5.008001; + +use strict; +use warnings; + ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +my $loaded = 0; BEGIN { $| = 1; print "1..95\n"; } END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( extract_quotelike ); $loaded = 1; print "ok 1\n"; -$count=2; +my $count=2; use vars qw( $DEBUG ); #$DEBUG=1; sub debug { print "\t>>>",@_ if $ENV{DEBUG} } @@ -20,48 +26,50 @@ sub esc { my $x = shift||'<undef>'; $x =~ s/\n/\\n/gs; $x } ######################### End of black magic. +## no critic (BuiltinFunctions::ProhibitStringyEval) -$cmd = "print"; -$neg = 0; +my $cmd = "print"; +my $neg = 0; +my $str; while (defined($str = <DATA>)) { - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - my $setup_cmd = ($str =~ s/\A\{(.*)\}//) ? $1 : ''; - my $tests = 'sl'; - $str =~ s/\\n/\n/g; - my $orig = $str; - - eval $setup_cmd if $setup_cmd ne ''; - if($tests =~ /l/) { - debug "\tUsing: $cmd\n"; - debug "\t on: [" . esc($setup_cmd) . "][" . esc($str) . "]\n"; - my @res; - eval qq{\@res = $cmd; }; - debug "\t got:\n" . join "", map { "\t\t\t$_: [" . esc($res[$_]) . "]\n"} (0..$#res); - debug "\t left: [" . esc($str) . "]\n"; - debug "\t pos: [" . esc(substr($str,pos($str))) . "...]\n"; - print "not " if (substr($str,pos($str),1) eq ';')==$neg; - print "ok ", $count++; - print "\n"; - } - - eval $setup_cmd if $setup_cmd ne ''; - if($tests =~ /s/) { - $str = $orig; - debug "\tUsing: scalar $cmd\n"; - debug "\t on: [" . esc($str) . "]\n"; - $var = eval $cmd; - print " ($@)" if $@ && $DEBUG; - $var = "<undef>" unless defined $var; - debug "\t scalar got: [" . esc($var) . "]\n"; - debug "\t scalar left: [" . esc($str) . "]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print "\n"; - } + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + my $setup_cmd = ($str =~ s/\A\{(.*)\}//) ? $1 : ''; + my $tests = 'sl'; + $str =~ s/\\n/\n/g; + my $orig = $str; + + eval $setup_cmd if $setup_cmd ne ''; + if($tests =~ /l/) { + debug "\tUsing: $cmd\n"; + debug "\t on: [" . esc($setup_cmd) . "][" . esc($str) . "]\n"; + my @res; + eval qq{\@res = $cmd; }; + debug "\t got:\n" . join "", map { "\t\t\t$_: [" . esc($res[$_]) . "]\n"} (0..$#res); + debug "\t left: [" . esc($str) . "]\n"; + debug "\t pos: [" . esc(substr($str,pos($str))) . "...]\n"; + print "not " if (substr($str,pos($str),1) eq ';')==$neg; + print "ok ", $count++; + print "\n"; + } + + eval $setup_cmd if $setup_cmd ne ''; + if($tests =~ /s/) { + $str = $orig; + debug "\tUsing: scalar $cmd\n"; + debug "\t on: [" . esc($str) . "]\n"; + my $var = eval $cmd; + print " ($@)" if $@ && $DEBUG; + $var = "<undef>" unless defined $var; + debug "\t scalar got: [" . esc($var) . "]\n"; + debug "\t scalar left: [" . esc($str) . "]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print "\n"; + } } # fails in Text::Balanced 1.95 @@ -71,7 +79,7 @@ print "not " if $z[0] eq ''; print "ok ", $count++; print "\n"; - + __DATA__ # USING: extract_quotelike($str); @@ -92,9 +100,9 @@ __DATA__ <<""; done()\nline1\nline2\n\n and next <<; done()\nline1\nline2\n\n and next # fails in Text::Balanced 1.95 -<<EOHERE;\nEOHERE\n; +<<EOHERE;\nEOHERE\n; # fails in Text::Balanced 1.95 -<<"*";\n\n*\n; +<<"*";\n\n*\n; "this is a nested $var[$x] {"; /a/gci; @@ -128,8 +136,8 @@ y/x/y/; { $tests = 'l'; pos($str)=6 }012345<<E;\n\nE\n # THESE SHOULD FAIL -s<$self->{pat}>{$self->{sub}}; # CAN'T HANDLE '>' in '->' -s-$self->{pap}-$self->{sub}-; # CAN'T HANDLE '-' in '->' -<<EOHERE; done();\nline1\nline2\nEOHERE;\n; next; # RDEL HAS NO ';' -<<'EOHERE'; done();\nline1\nline2\nEOHERE;\n; next; # RDEF HAS NO ';' +s<$self->{pat}>{$self->{sub}}; # CAN'T HANDLE '>' in '->' +s-$self->{pap}-$self->{sub}-; # CAN'T HANDLE '-' in '->' +<<EOHERE; done();\nline1\nline2\nEOHERE;\n; next; # RDEL HAS NO ';' +<<'EOHERE'; done();\nline1\nline2\nEOHERE;\n; next; # RDEF HAS NO ';' << EOTHERE; done();\nline1\nline2\n EOTHERE\n; next; # RDEL IS "" (!) diff --git a/cpan/Text-Balanced/t/07_exttag.t b/cpan/Text-Balanced/t/07_exttag.t index 16a48b2ae3..fd7eff428f 100644 --- a/cpan/Text-Balanced/t/07_exttag.t +++ b/cpan/Text-Balanced/t/07_exttag.t @@ -1,113 +1,121 @@ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' +use 5.008001; + +use strict; +use warnings; + ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +my $loaded = 0; BEGIN { $| = 1; print "1..53\n"; } END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( extract_tagged gen_extract_tagged ); $loaded = 1; print "ok 1\n"; -$count=2; +my $count=2; use vars qw( $DEBUG ); sub debug { print "\t>>>",@_ if $DEBUG } ######################### End of black magic. +## no critic (BuiltinFunctions::ProhibitStringyEval) -$cmd = "print"; -$neg = 0; +my $cmd = "print"; +my $neg = 0; +my $str; while (defined($str = <DATA>)) { - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; - - my @res; - $var = eval "\@res = $cmd"; - debug "\t list got: [" . join("|",map {defined $_ ? $_ : '<undef>'} @res) . "]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; - - pos $str = 0; - $var = eval $cmd; - $var = "<undef>" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; + + my @res; + my $var = eval "\@res = $cmd"; + debug "\t list got: [" . join("|",map {defined $_ ? $_ : '<undef>'} @res) . "]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; + + pos $str = 0; + $var = eval $cmd; + $var = "<undef>" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; } __DATA__ # USING: gen_extract_tagged("BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)")->($str); - ignore\n this and then BEGINHERE at the ENDHERE; - ignore\n this and then BEGINTHIS at the ENDTHIS; + ignore\n this and then BEGINHERE at the ENDHERE; + ignore\n this and then BEGINTHIS at the ENDTHIS; # USING: extract_tagged($str,"BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)"); - ignore\n this and then BEGINHERE at the ENDHERE; - ignore\n this and then BEGINTHIS at the ENDTHIS; + ignore\n this and then BEGINHERE at the ENDHERE; + ignore\n this and then BEGINTHIS at the ENDTHIS; # USING: extract_tagged($str,"BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)"); - ignore\n this and then BEGINHERE at the ENDHERE; - ignore\n this and then BEGINTHIS at the ENDTHIS; + ignore\n this and then BEGINHERE at the ENDHERE; + ignore\n this and then BEGINTHIS at the ENDTHIS; # THIS SHOULD FAIL - ignore\n this and then BEGINTHIS at the ENDTHAT; + ignore\n this and then BEGINTHIS at the ENDTHAT; # USING: extract_tagged($str,"BEGIN","END","(?s).*?(?=BEGIN)"); - ignore\n this and then BEGIN at the END; + ignore\n this and then BEGIN at the END; # USING: extract_tagged($str); - <A-1 HREF="#section2">some text</A-1>; + <A-1 HREF="#section2">some text</A-1>; # USING: extract_tagged($str,qr/<[A-Z]+>/,undef, undef, {ignore=>["<BR>"]}); - <A>aaa<B>bbb<BR>ccc</B>ddd</A>; + <A>aaa<B>bbb<BR>ccc</B>ddd</A>; # USING: extract_tagged($str,"BEGIN","END"); - BEGIN at the BEGIN keyword and END at the END; - BEGIN at the beginning and end at the END; + BEGIN at the BEGIN keyword and END at the END; + BEGIN at the beginning and end at the END; # USING: extract_tagged($str,undef,undef,undef,{ignore=>["<[^>]*/>"]}); - <A>aaa<B>bbb<BR/>ccc</B>ddd</A>; + <A>aaa<B>bbb<BR/>ccc</B>ddd</A>; # USING: extract_tagged($str,";","-",undef,{reject=>[";"],fail=>"MAX"}); - ; at the ;-) keyword + ; at the ;-) keyword # USING: extract_tagged($str,"<[A-Z]+>",undef, undef, {ignore=>["<BR>"]}); - <A>aaa<B>bbb<BR>ccc</B>ddd</A>; + <A>aaa<B>bbb<BR>ccc</B>ddd</A>; # THESE SHOULD FAIL - BEGIN at the beginning and end at the end; - BEGIN at the BEGIN keyword and END at the end; + BEGIN at the beginning and end at the end; + BEGIN at the BEGIN keyword and END at the end; # TEST EXTRACTION OF TAGGED STRINGS # USING: extract_tagged($str,"BEGIN","END",undef,{reject=>["BEGIN","END"]}); # THESE SHOULD FAIL - BEGIN at the BEGIN keyword and END at the end; + BEGIN at the BEGIN keyword and END at the end; # USING: extract_tagged($str,";","-",undef,{reject=>[";"],fail=>"PARA"}); - ; at the ;-) keyword + ; at the ;-) keyword # USING: extract_tagged($str); - <A>some text</A>; - <B>some text<A>other text</A></B>; - <A>some text<A>other text</A></A>; - <A HREF="#section2">some text</A>; + <A>some text</A>; + <B>some text<A>other text</A></B>; + <A>some text<A>other text</A></A>; + <A HREF="#section2">some text</A>; # THESE SHOULD FAIL - <A>some text - <A>some text<A>other text</A>; - <B>some text<A>other text</B>; + <A>some text + <A>some text<A>other text</A>; + <B>some text<A>other text</B>; diff --git a/cpan/Text-Balanced/t/08_extvar.t b/cpan/Text-Balanced/t/08_extvar.t index a33ac919ec..f527b843e0 100644 --- a/cpan/Text-Balanced/t/08_extvar.t +++ b/cpan/Text-Balanced/t/08_extvar.t @@ -1,53 +1,61 @@ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' +use 5.008001; + +use strict; +use warnings; + ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +my $loaded = 0; BEGIN { $| = 1; print "1..183\n"; } END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( extract_variable ); $loaded = 1; print "ok 1\n"; -$count=2; +my $count=2; use vars qw( $DEBUG ); sub debug { print "\t>>>",@_ if $DEBUG } ######################### End of black magic. +## no critic (BuiltinFunctions::ProhibitStringyEval) -$cmd = "print"; -$neg = 0; +my $cmd = "print"; +my $neg = 0; +my $str; while (defined($str = <DATA>)) { - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; - my @res; - $var = eval "\@res = $cmd"; - debug "\t list got: [" . join("|",map {defined $_ ? $_ : '<undef>'} @res) . "]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + my @res; + my $var = eval "\@res = $cmd"; + debug "\t list got: [" . join("|",map {defined $_ ? $_ : '<undef>'} @res) . "]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; - pos $str = 0; - $var = eval $cmd; - $var = "<undef>" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + pos $str = 0; + $var = eval $cmd; + $var = "<undef>" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; } __DATA__ diff --git a/cpan/Text-Balanced/t/09_gentag.t b/cpan/Text-Balanced/t/09_gentag.t index 0dd55a5f3f..1a82ae1e21 100644 --- a/cpan/Text-Balanced/t/09_gentag.t +++ b/cpan/Text-Balanced/t/09_gentag.t @@ -1,102 +1,115 @@ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' +use 5.008001; + +use strict; +use warnings; + ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +my $loaded = 0; BEGIN { $| = 1; print "1..37\n"; } END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( gen_extract_tagged ); $loaded = 1; print "ok 1\n"; -$count=2; +my $count=2; use vars qw( $DEBUG ); sub debug { print "\t>>>",@_ if $DEBUG } ######################### End of black magic. +## no critic (BuiltinFunctions::ProhibitStringyEval) -$cmd = "print"; -$neg = 0; +my $cmd = "print"; +my $neg = 0; +my $str; while (defined($str = <DATA>)) { - chomp $str; - $str =~ s/\\n/\n/g; - if ($str =~ s/\A# USING://) - { - $neg = 0; - eval{local$^W;*f = eval $str || die}; - next; - } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; - - my @res; - $var = eval { @res = f($str) }; - debug "\t list got: [" . join("|",map {defined $_ ? $_ : '<undef>'} @res) . "]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; - - pos $str = 0; - $var = eval { scalar f($str) }; - $var = "<undef>" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + chomp $str; + $str =~ s/\\n/\n/g; + if ($str =~ s/\A# USING://) + { + $neg = 0; + eval { + # Capture "Subroutine main::f redefined" warning + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, shift; }; + *f = eval $str || die; + }; + next; + } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; + + my @res; + my $var = eval { @res = f($str) }; + debug "\t list got: [" . join("|",map {defined $_ ? $_ : '<undef>'} @res) . "]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; + + pos $str = 0; + $var = eval { scalar f($str) }; + $var = "<undef>" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; } __DATA__ # USING: gen_extract_tagged('{','}'); - { a test }; + { a test }; # USING: gen_extract_tagged(qr/<[A-Z]+>/,undef, undef, {ignore=>["<BR>"]}); - <A>aaa<B>bbb<BR>ccc</B>ddd</A>; + <A>aaa<B>bbb<BR>ccc</B>ddd</A>; # USING: gen_extract_tagged("BEGIN","END"); - BEGIN at the BEGIN keyword and END at the END; - BEGIN at the beginning and end at the END; + BEGIN at the BEGIN keyword and END at the END; + BEGIN at the beginning and end at the END; # USING: gen_extract_tagged(undef,undef,undef,{ignore=>["<[^>]*/>"]}); - <A>aaa<B>bbb<BR/>ccc</B>ddd</A>; + <A>aaa<B>bbb<BR/>ccc</B>ddd</A>; # USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"MAX"}); - ; at the ;-) keyword + ; at the ;-) keyword # USING: gen_extract_tagged("<[A-Z]+>",undef, undef, {ignore=>["<BR>"]}); - <A>aaa<B>bbb<BR>ccc</B>ddd</A>; + <A>aaa<B>bbb<BR>ccc</B>ddd</A>; # THESE SHOULD FAIL - BEGIN at the beginning and end at the end; - BEGIN at the BEGIN keyword and END at the end; + BEGIN at the beginning and end at the end; + BEGIN at the BEGIN keyword and END at the end; # TEST EXTRACTION OF TAGGED STRINGS # USING: gen_extract_tagged("BEGIN","END",undef,{reject=>["BEGIN","END"]}); # THESE SHOULD FAIL - BEGIN at the BEGIN keyword and END at the end; + BEGIN at the BEGIN keyword and END at the end; # USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"PARA"}); - ; at the ;-) keyword + ; at the ;-) keyword # USING: gen_extract_tagged(); - <A>some text</A>; - <B>some text<A>other text</A></B>; - <A>some text<A>other text</A></A>; - <A HREF="#section2">some text</A>; + <A>some text</A>; + <B>some text<A>other text</A></B>; + <A>some text<A>other text</A></A>; + <A HREF="#section2">some text</A>; # THESE SHOULD FAIL - <A>some text - <A>some text<A>other text</A>; - <B>some text<A>other text</B>; + <A>some text + <A>some text<A>other text</A>; + <B>some text<A>other text</B>; diff --git a/cpan/Text-Balanced/t/94_changes.t b/cpan/Text-Balanced/t/94_changes.t new file mode 100644 index 0000000000..400ec89093 --- /dev/null +++ b/cpan/Text-Balanced/t/94_changes.t @@ -0,0 +1,48 @@ +#!perl +#=============================================================================== +# +# t/94_changes.t +# +# DESCRIPTION +# Test script to check CPAN::Changes conformance. +# +# COPYRIGHT +# Copyright (C) 2015 Steve Hay. All rights reserved. +# +# LICENCE +# This script is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU +# General Public License or the Artistic License, as specified in the LICENCE +# file. +# +#=============================================================================== + +use 5.008001; + +use strict; +use warnings; + +use Test::More; + +#=============================================================================== +# MAIN PROGRAM +#=============================================================================== + +MAIN: { + plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING}; + + my $ok = eval { + require Test::CPAN::Changes; + Test::CPAN::Changes->import(); + 1; + }; + + if (not $ok) { + plan skip_all => 'Test::CPAN::Changes required to test Changes'; + } + else { + changes_ok(); + } +} + +#=============================================================================== diff --git a/cpan/Text-Balanced/t/95_critic.t b/cpan/Text-Balanced/t/95_critic.t new file mode 100644 index 0000000000..1e575423eb --- /dev/null +++ b/cpan/Text-Balanced/t/95_critic.t @@ -0,0 +1,48 @@ +#!perl +#=============================================================================== +# +# t/95_critic.t +# +# DESCRIPTION +# Test script to check Perl::Critic conformance. +# +# COPYRIGHT +# Copyright (C) 2015 Steve Hay. All rights reserved. +# +# LICENCE +# This script is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU +# General Public License or the Artistic License, as specified in the LICENCE +# file. +# +#=============================================================================== + +use 5.008001; + +use strict; +use warnings; + +use Test::More; + +#=============================================================================== +# MAIN PROGRAM +#=============================================================================== + +MAIN: { + plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING}; + + my $ok = eval { + require Test::Perl::Critic; + Test::Perl::Critic->import(-profile => ''); + 1; + }; + + if (not $ok) { + plan skip_all => 'Test::Perl::Critic required to test with Perl::Critic'; + } + else { + all_critic_ok('.'); + } +} + +#=============================================================================== diff --git a/cpan/Text-Balanced/t/96_pmv.t b/cpan/Text-Balanced/t/96_pmv.t new file mode 100644 index 0000000000..e1197da5de --- /dev/null +++ b/cpan/Text-Balanced/t/96_pmv.t @@ -0,0 +1,32 @@ +#!/usr/bin/perl + +# Test that our declared minimum Perl version matches our syntax + +use 5.008001; + +use strict; +use warnings; + +use Test::More; + +my @MODULES = ( + 'Perl::MinimumVersion 1.20', + 'Test::MinimumVersion 0.101082', +); + +# Don't run tests for installs +use Test::More; +unless ( $ENV{AUTHOR_TESTING} ) { + plan( skip_all => "Author testing only" ); +} + +# Load the testing modules +foreach my $MODULE ( @MODULES ) { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + eval "use $MODULE"; + if ( $@ ) { + plan( skip_all => "$MODULE not available for testing" ); + } +} + +all_minimum_version_from_mymetayml_ok(); diff --git a/cpan/Text-Balanced/t/97_pod.t b/cpan/Text-Balanced/t/97_pod.t new file mode 100644 index 0000000000..d0f4caec64 --- /dev/null +++ b/cpan/Text-Balanced/t/97_pod.t @@ -0,0 +1,32 @@ +#!/usr/bin/perl + +# Test that the syntax of our POD documentation is valid + +use 5.008001; + +use strict; +use warnings; + +use Test::More; + +my @MODULES = ( + 'Pod::Simple 3.07', + 'Test::Pod 1.26', +); + +# Don't run tests for installs +use Test::More; +unless ( $ENV{AUTHOR_TESTING} ) { + plan( skip_all => "Author testing only" ); +} + +# Load the testing modules +foreach my $MODULE ( @MODULES ) { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + eval "use $MODULE"; + if ( $@ ) { + plan( skip_all => "$MODULE not available for testing" ); + } +} + +all_pod_files_ok(); diff --git a/cpan/Text-Balanced/t/98_pod_coverage.t b/cpan/Text-Balanced/t/98_pod_coverage.t new file mode 100644 index 0000000000..cce4f94c60 --- /dev/null +++ b/cpan/Text-Balanced/t/98_pod_coverage.t @@ -0,0 +1,51 @@ +#!perl +#=============================================================================== +# +# t/99_pod_coverage.t +# +# DESCRIPTION +# Test script to check POD coverage. +# +# COPYRIGHT +# Copyright (C) 2015 Steve Hay. All rights reserved. +# +# LICENCE +# This script is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU +# General Public License or the Artistic License, as specified in the LICENCE +# file. +# +#=============================================================================== + +use 5.008001; + +use strict; +use warnings; + +use Test::More; + +#=============================================================================== +# MAIN PROGRAM +#=============================================================================== + +MAIN: { + plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING}; + + my $ok = eval { + require Test::Pod::Coverage; + Test::Pod::Coverage->import(); + 1; + }; + + if (not $ok) { + plan skip_all => 'Test::Pod::Coverage required to test POD coverage'; + } + elsif ($Test::Pod::Coverage::VERSION < 0.08) { + plan skip_all => 'Test::Pod::Coverage 0.08 or higher required to test POD coverage'; + } + else { + all_pod_coverage_ok(); + } +} + +#=============================================================================== |