summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Balanced.pm
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2024-03-15 03:06:35 +0000
committerNorbert Preining <norbert@preining.info>2024-03-15 03:06:35 +0000
commit12679ab7d3c2a210f4123163671b532b8b55d5f9 (patch)
tree0060d13467186ad977f4e73488ee20dd6c0017ab /systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Balanced.pm
parent62170822e034fdd3f81de7274835d0d3b0467100 (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.pm317
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