diff options
author | Norbert Preining <norbert@preining.info> | 2024-03-15 03:06:35 +0000 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2024-03-15 03:06:35 +0000 |
commit | 12679ab7d3c2a210f4123163671b532b8b55d5f9 (patch) | |
tree | 0060d13467186ad977f4e73488ee20dd6c0017ab /systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Balanced.pm | |
parent | 62170822e034fdd3f81de7274835d0d3b0467100 (diff) |
CTAN sync 202403150306
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Balanced.pm')
-rw-r--r-- | systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Balanced.pm | 317 |
1 files changed, 184 insertions, 133 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Balanced.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Balanced.pm index 324a023f38..49f3d8926c 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Balanced.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Balanced.pm @@ -1,6 +1,7 @@ # Copyright (C) 1997-2001 Damian Conway. All rights reserved. # Copyright (C) 2009 Adam Kennedy. -# Copyright (C) 2015 Steve Hay. All rights reserved. +# Copyright (C) 2015, 2022 Steve Hay and other contributors. 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 @@ -17,7 +18,7 @@ use Exporter (); use vars qw { $VERSION @ISA %EXPORT_TAGS }; BEGIN { - $VERSION = '2.04'; + $VERSION = '2.06'; @ISA = 'Exporter'; %EXPORT_TAGS = ( ALL => [ qw{ @@ -37,14 +38,22 @@ BEGIN { Exporter::export_ok_tags('ALL'); -## no critic (Subroutines::ProhibitSubroutinePrototypes) - -# PROTOTYPES - -sub _match_bracketed($$$$$$); -sub _match_variable($$); -sub _match_codeblock($$$$$$$); -sub _match_quotelike($$$$); +our $RE_PREREGEX_PAT = qr#( + [!=]~ + | split|grep|map + | not|and|or|xor +)#x; +our $RE_EXPR_PAT = qr#( + (?:\*\*|&&|\|\||<<|>>|//|[-+*x%^&|.])=? + | /(?:[^/]) + | =(?!>) + | return + | [\(\[] +)#x; +our $RE_NUM = qr/\s*[+\-.0-9][+\-.0-9e]*/i; # numerical constant + +our %ref2slashvalid; # is quotelike /.../ pattern valid here for given textref? +our %ref2qmarkvalid; # is quotelike ?...? pattern valid here for given textref? # HANDLE RETURN VALUES IN VARIOUS CONTEXTS @@ -99,6 +108,7 @@ sub _succeed { } # BUILD A PATTERN MATCHING A SIMPLE DELIMITED STRING +## no critic (Subroutines::ProhibitSubroutinePrototypes) sub gen_delimited_pat($;$) # ($delimiters;$escapes) { @@ -132,6 +142,7 @@ sub gen_delimited_pat($;$) # ($delimiters;$escapes) sub extract_delimited (;$$$$) { my $textref = defined $_[0] ? \$_[0] : \$_; + $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 if !pos($$textref); # reset my $wantarray = wantarray; my $del = defined $_[1] ? $_[1] : qq{\'\"\`}; my $pre = defined $_[2] ? $_[2] : '\s*'; @@ -149,33 +160,45 @@ sub extract_delimited (;$$$$) $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 %eb_delim_cache; +sub _eb_delims { + my ($ldel_orig) = @_; + return @{ $eb_delim_cache{$ldel_orig} } if $eb_delim_cache{$ldel_orig}; my $qdel = ""; my $quotelike; + my $ldel = $ldel_orig; $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 @{ $eb_delim_cache{$ldel_orig} = [] } unless $rdel =~ tr/[({</])}>/; + my $posbug = pos; + $ldel = join('|', map { quotemeta $_ } split('', $ldel)); + $rdel = join('|', map { quotemeta $_ } split('', $rdel)); + pos = $posbug; + @{ $eb_delim_cache{$ldel_orig} = [ + qr/\G($ldel)/, $qdel && qr/\G([$qdel])/, $quotelike, qr/\G($rdel)/ + ] }; +} +sub extract_bracketed (;$$$) +{ + my $textref = defined $_[0] ? \$_[0] : \$_; + $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 if !pos($$textref); # reset + my $ldel = defined $_[1] ? $_[1] : '{([<'; + my $pre = defined $_[2] ? qr/\G$_[2]/ : qr/\G\s*/; + my $wantarray = wantarray; + my @ret = _eb_delims($ldel); + unless (@ret) { 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); + my @match = _match_bracketed($textref, $pre, @ret); return _fail ($wantarray, $textref) unless @match; @@ -186,11 +209,11 @@ sub extract_bracketed (;$$$) ); } -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) + unless ($$textref =~ m/$pre/gc) { _failmsg "Did not find prefix: /$pre/", $startpos; return; @@ -198,7 +221,7 @@ sub _match_bracketed($$$$$$) # $textref, $pre, $ldel, $qdel, $quotelike, $rde $ldelpos = pos $$textref; - unless ($$textref =~ m/\G($ldel)/gc) + unless ($$textref =~ m/$ldel/gc) { _failmsg "Did not find opening bracket after prefix: \"$pre\"", pos $$textref; @@ -212,11 +235,11 @@ sub _match_bracketed($$$$$$) # $textref, $pre, $ldel, $qdel, $quotelike, $rde { next if $$textref =~ m/\G\\./gcs; - if ($$textref =~ m/\G($ldel)/gc) + if ($$textref =~ m/$ldel/gc) { push @nesting, $1; } - elsif ($$textref =~ m/\G($rdel)/gc) + elsif ($$textref =~ m/$rdel/gc) { my ($found, $brackettype) = ($1, $1); if ($#nesting < 0) @@ -237,7 +260,7 @@ sub _match_bracketed($$$$$$) # $textref, $pre, $ldel, $qdel, $quotelike, $rde } last if $#nesting < 0; } - elsif ($qdel && $$textref =~ m/\G([$qdel])/gc) + elsif ($qdel && $$textref =~ m/$qdel/gc) { $$textref =~ m/\G[^\\$1]*(?:\\.[^\\$1]*)*(\Q$1\E)/gsc and next; _failmsg "Unmatched embedded quote ($1)", @@ -245,8 +268,9 @@ sub _match_bracketed($$$$$$) # $textref, $pre, $ldel, $qdel, $quotelike, $rde pos $$textref = $startpos; return; } - elsif ($quotelike && _match_quotelike($textref,"",1,0)) + elsif ($quotelike && _match_quotelike($textref,qr/\G()/,$ref2slashvalid{$textref},$ref2qmarkvalid{$textref})) { + $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 1; # back-compat next; } @@ -281,12 +305,14 @@ sub _revbracket($) my $XMLNAME = q{[a-zA-Z_:][a-zA-Z0-9_:.-]*}; +my $et_default_ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; sub extract_tagged (;$$$$$) # ($text, $opentag, $closetag, $pre, \%options) { my $textref = defined $_[0] ? \$_[0] : \$_; + $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 if !pos($$textref); # reset my $ldel = $_[1]; my $rdel = $_[2]; - my $pre = defined $_[3] ? $_[3] : '\s*'; + my $pre = defined $_[3] ? qr/\G$_[3]/ : qr/\G\s*/; my %options = defined $_[4] ? %{$_[4]} : (); my $omode = defined $options{fail} ? $options{fail} : ''; my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}}) @@ -298,7 +324,7 @@ sub extract_tagged (;$$$$$) # ($text, $opentag, $closetag, $pre, \%options) : '' ; - if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; } + $ldel = $et_default_ldel if !defined $ldel; $@ = undef; my @match = _match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore); @@ -316,7 +342,7 @@ sub _match_tagged # ($$$$$$$) my ($startpos, $opentagpos, $textpos, $parapos, $closetagpos, $endpos) = ( pos($$textref) = pos($$textref)||0 ); - unless ($$textref =~ m/\G($pre)/gc) + unless ($$textref =~ m/$pre/gc) { _failmsg "Did not find prefix: /$pre/", pos $$textref; goto failed; @@ -433,7 +459,8 @@ sub extract_variable (;$$) { my $textref = defined $_[0] ? \$_[0] : \$_; return ("","","") unless defined $$textref; - my $pre = defined $_[1] ? $_[1] : '\s*'; + $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 if !pos($$textref); # reset + my $pre = defined $_[1] ? qr/\G$_[1]/ : qr/\G\s*/; my @match = _match_variable($textref,$pre); @@ -443,14 +470,14 @@ sub extract_variable (;$$) @match[2..3,4..5,0..1]; # MATCH, REMAINDER, PREFIX } -sub _match_variable($$) +sub _match_variable { # $# # $^ # $$ my ($textref, $pre) = @_; my $startpos = pos($$textref) = pos($$textref)||0; - unless ($$textref =~ m/\G($pre)/gc) + unless ($$textref =~ m/$pre/gc) { _failmsg "Did not find prefix: /$pre/", pos $$textref; return; @@ -467,8 +494,9 @@ sub _match_variable($$) 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 '$$' ) + or _match_codeblock($textref, qr/\G()/, '\{', qr/\G\s*(\})/, '\{', '\}', 0, 1) + or $deref eq '$#' or $deref eq '$$' + or pos($$textref) == length $$textref ) { _failmsg "Bad identifier after dereferencer", pos $$textref; pos $$textref = $startpos; @@ -480,16 +508,17 @@ sub _match_variable($$) { 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); + qr/\G\s*->\s*(?:[_a-zA-Z]\w+\s*)?/, + qr/[({[]/, qr/\G\s*([)}\]])/, + qr/[({[]/, qr/[)}\]]/, 0, 1); next if _match_codeblock($textref, - qr/\s*/, qr/[{[]/, qr/[}\]]/, - qr/[{[]/, qr/[}\]]/, 0); - next if _match_variable($textref,'\s*->\s*'); + qr/\G\s*/, qr/[{[]/, qr/\G\s*([}\]])/, + qr/[{[]/, qr/[}\]]/, 0, 1); + next if _match_variable($textref,qr/\G\s*->\s*/); next if $$textref =~ m/\G\s*->\s*\w+(?![{([])/gc; last; } + $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 0; my $endpos = pos($$textref); return ($startpos, $varpos-$startpos, @@ -498,14 +527,11 @@ sub _match_variable($$) ); } -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 %ec_delim_cache; +sub _ec_delims { + my ($ldel_inner, $ldel_outer) = @_; + return @{ $ec_delim_cache{$ldel_outer}{$ldel_inner} } + if $ec_delim_cache{$ldel_outer}{$ldel_inner}; my $rdel_inner = $ldel_inner; my $rdel_outer = $ldel_outer; my $posbug = pos; @@ -516,23 +542,34 @@ sub extract_codeblock (;$$$$$) $_ = '('.join('|',map { quotemeta $_ } split('',$_)).')' } pos = $posbug; + @{ $ec_delim_cache{$ldel_outer}{$ldel_inner} = [ + $ldel_outer, qr/\G\s*($rdel_outer)/, $ldel_inner, $rdel_inner + ] }; +} +sub extract_codeblock (;$$$$$) +{ + my $textref = defined $_[0] ? \$_[0] : \$_; + $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 if !pos($$textref); # reset + my $wantarray = wantarray; + my $ldel_inner = defined $_[1] ? $_[1] : '{'; + my $pre = !defined $_[2] ? qr/\G\s*/ : qr/\G$_[2]/; + my $ldel_outer = defined $_[3] ? $_[3] : $ldel_inner; + my $rd = $_[4]; + my @delims = _ec_delims($ldel_inner, $ldel_outer); - my @match = _match_codeblock($textref, $pre, - $ldel_outer, $rdel_outer, - $ldel_inner, $rdel_inner, - $rd); + my @match = _match_codeblock($textref, $pre, @delims, $rd, 1); return _fail($wantarray, $textref) unless @match; return _succeed($wantarray, $textref, @match[2..3,4..5,0..1] # MATCH, REMAINDER, PREFIX ); - } -sub _match_codeblock($$$$$$$) +sub _match_codeblock { - my ($textref, $pre, $ldel_outer, $rdel_outer, $ldel_inner, $rdel_inner, $rd) = @_; + my ($textref, $pre, $ldel_outer, $rdel_outer, $ldel_inner, $rdel_inner, $rd, $no_backcompat) = @_; + $rdel_outer = qr/\G\s*($rdel_outer)/ if !$no_backcompat; # Switch calls this func directly my $startpos = pos($$textref) = pos($$textref) || 0; - unless ($$textref =~ m/\G($pre)/gc) + unless ($$textref =~ m/$pre/gc) { _failmsg qq{Did not match prefix /$pre/ at"} . substr($$textref,pos($$textref),20) . @@ -553,13 +590,13 @@ sub _match_codeblock($$$$$$$) my $closing = $1; $closing =~ tr/([<{/)]>}/; my $matched; - my $patvalid = 1; + $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 + if !pos($$textref) or !defined $ref2slashvalid{$textref}; # default, or reset while (pos($$textref) < length($$textref)) { - $matched = ''; if ($rd && $$textref =~ m#\G(\Q(?)\E|\Q(s?)\E|\Q(s)\E)#gc) { - $patvalid = 0; + $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 0; next; } @@ -568,7 +605,7 @@ sub _match_codeblock($$$$$$$) next; } - if ($$textref =~ m/\G\s*($rdel_outer)/gc) + if ($$textref =~ m/$rdel_outer/gc) { unless ($matched = ($closing && $1 eq $closing) ) { @@ -581,31 +618,22 @@ sub _match_codeblock($$$$$$$) last; } - if (_match_variable($textref,'\s*') || - _match_quotelike($textref,'\s*',$patvalid,$patvalid) ) + if (_match_variable($textref,qr/\G\s*/) || + _match_quotelike($textref,qr/\G\s*/,$ref2slashvalid{$textref},$ref2qmarkvalid{$textref}) ) { - $patvalid = 0; + $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 0; next; } - - # NEED TO COVER MANY MORE CASES HERE!!! - if ($$textref =~ m#\G\s*(?!$ldel_inner) - ( [-+*x/%^&|.]=? - | [!=]~ - | =(?!>) - | (\*\*|&&|\|\||<<|>>)=? - | split|grep|map|return - | [([] - )#gcx) + if ($$textref =~ m#\G\s*(?!$ldel_inner)(?:$RE_PREREGEX_PAT|$RE_EXPR_PAT)#gc) { - $patvalid = 1; + $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 1; next; } - if ( _match_codeblock($textref, '\s*', $ldel_inner, $rdel_inner, $ldel_inner, $rdel_inner, $rd) ) + if ( _match_codeblock($textref, qr/\G\s*/, $ldel_inner, qr/\G\s*($rdel_inner)/, $ldel_inner, $rdel_inner, $rd, 1) ) { - $patvalid = 1; + $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 1; next; } @@ -618,7 +646,7 @@ sub _match_codeblock($$$$$$$) last; } - $patvalid = 0; + $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 0; $$textref =~ m/\G\s*(\w+|[-=>]>|.|\Z)/gc; } continue { $@ = undef } @@ -630,6 +658,7 @@ sub _match_codeblock($$$$$$$) return; } + $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = undef; my $endpos = pos($$textref); return ( $startpos, $codepos-$startpos, $codepos, $endpos-$codepos, @@ -654,10 +683,11 @@ my %mods = ( sub extract_quotelike (;$$) { my $textref = $_[0] ? \$_[0] : \$_; + $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 if !pos($$textref); # reset my $wantarray = wantarray; - my $pre = defined $_[1] ? $_[1] : '\s*'; + my $pre = defined $_[1] ? qr/\G$_[1]/ : qr/\G\s*/; - my @match = _match_quotelike($textref,$pre,1,0); + my @match = _match_quotelike($textref,$pre,$ref2slashvalid{$textref},$ref2qmarkvalid{$textref}); return _fail($wantarray, $textref) unless @match; return _succeed($wantarray, $textref, $match[2], $match[18]-$match[2], # MATCH @@ -668,17 +698,19 @@ sub extract_quotelike (;$$) ); }; -sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) +my %maybe_quote = map +($_=>1), qw(" ' `); +sub _match_quotelike { - my ($textref, $pre, $rawmatch, $qmark) = @_; + my ($textref, $pre, $allow_slash_match, $allow_qmark_match) = @_; + $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 + if !pos($$textref) or !defined $ref2slashvalid{$textref}; # default, or reset 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) + unless ($$textref =~ m/$pre/gc) { _failmsg qq{Did not find prefix /$pre/ at "} . substr($$textref, pos($$textref), 20) . @@ -686,15 +718,13 @@ sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) pos $$textref; return; } - $oppos = pos($$textref); - + my $oppos = pos($$textref); my $initial = substr($$textref,$oppos,1); - - if ($initial && $initial =~ m|^[\"\'\`]| - || $rawmatch && $initial =~ m|^/| - || $qmark && $initial =~ m|^\?|) + if ($initial && $maybe_quote{$initial} + || $allow_slash_match && $initial eq '/' + || $allow_qmark_match && $initial eq '?') { - unless ($$textref =~ m/ \Q$initial\E [^\\$initial]* (\\.[^\\$initial]*)* \Q$initial\E /gcsx) + unless ($$textref =~ m/\G \Q$initial\E [^\\$initial]* (\\.[^\\$initial]*)* \Q$initial\E /gcsx) { _failmsg qq{Did not find closing delimiter to match '$initial' at "} . substr($$textref, $oppos, 20) . @@ -712,6 +742,7 @@ sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) } my $endpos = pos($$textref); + $ref2qmarkvalid{$textref} = $ref2slashvalid{$textref} = 0; return ( $startpos, $oppos-$startpos, # PREFIX $oppos, 0, # NO OPERATOR @@ -726,7 +757,7 @@ sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) ); } - unless ($$textref =~ m{\G(\b(?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<)}gc) + unless ($$textref =~ m{\G(\b(?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<(?=[a-zA-Z]|\s*['"`;,]))}gc) { _failmsg q{No quotelike operator found after prefix at "} . substr($$textref, pos($$textref), 20) . @@ -767,6 +798,7 @@ sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) $rd1pos = pos($$textref); $$textref =~ m{\Q$label\E\n}gc; $ld2pos = pos($$textref); + $ref2qmarkvalid{$textref} = $ref2slashvalid{$textref} = 0; return ( $startpos, $oppos-$startpos, # PREFIX $oppos, length($op), # OPERATOR @@ -786,19 +818,26 @@ sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) $ld1pos = pos($$textref); $str1pos = $ld1pos+1; - unless ($$textref =~ m/\G(\S)/gc) # SHOULD USE LOOKAHEAD + if ($$textref !~ m/\G(\S)/gc) # SHOULD USE LOOKAHEAD { _failmsg "No block delimiter found after quotelike $op", pos $$textref; pos $$textref = $startpos; return; } + elsif (substr($$textref, $ld1pos, 2) eq '=>') + { + _failmsg "quotelike $op was actually quoted by '=>'", + 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)) + defined(_match_bracketed($textref,qr/\G/,qr/\G($ldel1)/,"","",qr/\G($rdel1)/)) || do { pos $$textref = $startpos; return }; $ld2pos = pos($$textref); $rd1pos = $ld2pos-1; @@ -835,7 +874,7 @@ sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) if ($ldel2 =~ /[[(<{]/) { pos($$textref)--; # OVERCOME BROKEN LOOKAHEAD - defined(_match_bracketed($textref,"",$ldel2,"","",$rdel2)) + defined(_match_bracketed($textref,qr/\G/,qr/\G($ldel2)/,"","",qr/\G($rdel2)/)) || do { pos $$textref = $startpos; return }; } else @@ -854,6 +893,7 @@ sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) $$textref =~ m/\G($mods{$op})/gc; my $endpos = pos $$textref; + $ref2qmarkvalid{$textref} = $ref2slashvalid{$textref} = undef; return ( $startpos, $oppos-$startpos, # PREFIX @@ -874,10 +914,26 @@ my $def_func = [ sub { extract_quotelike($_[0],'') }, sub { extract_codeblock($_[0],'{}','') }, ]; +my %ref_not_regex = map +($_=>1), qw(CODE Text::Balanced::Extractor); +sub _update_patvalid { + my ($textref, $text) = @_; + if ($ref2slashvalid{$textref} && $text =~ m/(?:$RE_NUM|[\)\]])\s*$/) + { + $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 0; + } elsif (!$ref2slashvalid{$textref} && $text =~ m/$RE_PREREGEX_PAT\s*$/) + { + $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 1; + } elsif (!$ref2slashvalid{$textref} && $text =~ m/$RE_EXPR_PAT\s*$/) + { + $ref2slashvalid{$textref} = 1; + $ref2qmarkvalid{$textref} = 0; + } +} sub extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $ignoreunknown) { my $textref = defined($_[0]) ? \$_[0] : \$_; + $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 if !pos($$textref); # reset my $posbug = pos; my ($lastpos, $firstpos); my @fields = (); @@ -898,39 +954,28 @@ sub extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $ignoreun $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; - } + push @class, undef; + ($class[-1], $func) = %$func if ref($func) eq 'HASH'; + $func = qr/\G$func/ if !$ref_not_regex{ref $func}; } + my $unkpos; 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]; + my ($field, $pref); + my ($class, $func) = ($class[$i], $func[$i]); $lastpos = pos $$textref; if (ref($func) eq 'CODE') - { ($field,$rem,$pref) = @bits = $func->($$textref) } + { ($field,undef,$pref) = $func->($$textref) } elsif (ref($func) eq 'Text::Balanced::Extractor') - { @bits = $field = $func->extract($$textref) } - elsif( $$textref =~ m/\G$func/gc ) - { @bits = $field = defined($1) + { $field = $func->extract($$textref) } + elsif( $$textref =~ m/$func[$i]/gc ) + { $field = defined($1) ? $1 : substr($$textref, $-[0], $+[0] - $-[0]) } @@ -948,9 +993,8 @@ sub extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $ignoreun last FIELD if @fields == $max; } } - push @fields, $class - ? bless (\$field, $class) - : $field; + push @fields, $class ? bless(\$field, $class) : $field; + _update_patvalid($textref, $fields[-1]); $firstpos = $lastpos unless defined $firstpos; $lastpos = pos $$textref; last FIELD if @fields == $max; @@ -961,6 +1005,7 @@ sub extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $ignoreun { $unkpos = pos($$textref)-1 unless $igunk || defined $unkpos; + _update_patvalid($textref, substr $$textref, $unkpos, pos($$textref)-$unkpos); } } @@ -986,7 +1031,7 @@ sub gen_extract_tagged # ($opentag, $closetag, $pre, \%options) { my $ldel = $_[0]; my $rdel = $_[1]; - my $pre = defined $_[2] ? $_[2] : '\s*'; + my $pre = defined $_[2] ? qr/\G$_[2]/ : qr/\G\s*/; my %options = defined $_[3] ? %{$_[3]} : (); my $omode = defined $options{fail} ? $options{fail} : ''; my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}}) @@ -998,16 +1043,16 @@ sub gen_extract_tagged # ($opentag, $closetag, $pre, \%options) : '' ; - if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; } + $ldel = $et_default_ldel if !defined $ldel; my $posbug = pos; - for ($ldel, $pre, $bad, $ignore) { $_ = qr/$_/ if $_ } + for ($ldel, $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); + my @match = _match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore); return _fail(wantarray, $textref) unless @match; return _succeed wantarray, $textref, @@ -1027,7 +1072,9 @@ sub extract($$) # ($self, $text) package Text::Balanced::ErrorMsg; -use overload '""' => sub { "$_[0]->{error}, detected at offset $_[0]->{pos}" }; +use overload + '""' => sub { "$_[0]->{error}, detected at offset $_[0]->{pos}" }, + fallback => 1; 1; @@ -1450,7 +1497,7 @@ A string to be processed (C<$_> if the string is omitted or C<undef>) =item 2. -A string specifying a pattern to be matched as the opening tag. +A string specifying a pattern (i.e. regex) to be matched as the opening tag. If the pattern string is omitted (or C<undef>) then a pattern that matches any standard XML tag is used. @@ -1854,7 +1901,8 @@ C<"extract_quotelike">. C<extract_codeblock> takes the same initial three parameters as C<extract_bracketed>: a text to process, a set of delimiter brackets to look for, and a prefix to match first. It also takes an optional fourth parameter, which allows the -outermost delimiter brackets to be specified separately (see below). +outermost delimiter brackets to be specified separately (see below), +and a fifth parameter used only by L<Parse::RecDescent>. Omitting the first argument (input text) means process C<$_> instead. Omitting the second argument (delimiter brackets) indicates that only C<'{'> is to be used. @@ -2063,12 +2111,14 @@ operator (and removes it from $text): Finally, here is yet another way to do comma-separated value parsing: + $csv_text = "a,'x b',c"; @fields = extract_multiple($csv_text, [ sub { extract_delimited($_[0],q{'"}) }, - qr/([^,]+)(.*)/, + qr/([^,]+)/, ], undef,1); + # @fields is now ('a', "'x b'", 'c') The list in the second argument means: I<"Try and extract a ' or " delimited string, otherwise extract anything up to a comma...">. @@ -2084,7 +2134,7 @@ just make the last parameter undefined (or remove it). =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 +builds a Friedl-style optimized regex that matches a string delimited by any one of the characters in the single argument. For example: gen_delimited_pat(q{'"}) @@ -2360,7 +2410,8 @@ Copyright (C) 1997-2001 Damian Conway. All rights reserved. Copyright (C) 2009 Adam Kennedy. -Copyright (C) 2015, 2020 Steve Hay. All rights reserved. +Copyright (C) 2015, 2020, 2022 Steve Hay and other contributors. All rights +reserved. =head1 LICENCE @@ -2370,11 +2421,11 @@ License or the Artistic License, as specified in the F<LICENCE> file. =head1 VERSION -Version 2.04 +Version 2.06 =head1 DATE -11 Dec 2020 +05 Jun 2022 =head1 HISTORY |