summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/Text
diff options
context:
space:
mode:
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/Text')
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Balanced.pm317
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Text/ParseWords.pm74
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Tabs.pm81
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Wrap.pm72
4 files changed, 275 insertions, 269 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
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/ParseWords.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/ParseWords.pm
index 87f9c70a21..2bfe74d4a3 100644
--- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/ParseWords.pm
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/ParseWords.pm
@@ -1,8 +1,9 @@
package Text::ParseWords;
use strict;
+use warnings;
require 5.006;
-our $VERSION = "3.30";
+our $VERSION = "3.31";
use Exporter;
@@ -190,31 +191,46 @@ Text::ParseWords - parse text into an array of tokens or array of arrays
=head1 DESCRIPTION
-The &nested_quotewords() and &quotewords() functions accept a delimiter
+The C<nested_quotewords()> and C<quotewords()> functions accept a delimiter
(which can be a regular expression)
and a list of lines and then breaks those lines up into a list of
-words ignoring delimiters that appear inside quotes. &quotewords()
-returns all of the tokens in a single long list, while &nested_quotewords()
-returns a list of token lists corresponding to the elements of @lines.
-&parse_line() does tokenizing on a single string. The &*quotewords()
-functions simply call &parse_line(), so if you're only splitting
-one line you can call &parse_line() directly and save a function
+words ignoring delimiters that appear inside quotes. C<quotewords()>
+returns all of the tokens in a single long list, while C<nested_quotewords()>
+returns a list of token lists corresponding to the elements of C<@lines>.
+C<parse_line()> does tokenizing on a single string. The C<*quotewords()>
+functions simply call C<parse_line()>, so if you're only splitting
+one line you can call C<parse_line()> directly and save a function
call.
-The $keep argument is a boolean flag. If true, then the tokens are
-split on the specified delimiter, but all other characters (including
-quotes and backslashes) are kept in the tokens. If $keep is false then the
-&*quotewords() functions remove all quotes and backslashes that are
+The C<$keep> controls what happens with delimters and special characters:
+
+=over 4
+
+=item true
+
+If true, then the tokens are split on the specified delimiter,
+but all other characters (including quotes and backslashes)
+are kept in the tokens.
+
+=item false
+
+If $keep is false then the C<*quotewords()> functions
+remove all quotes and backslashes that are
not themselves backslash-escaped or inside of single quotes (i.e.,
-&quotewords() tries to interpret these characters just like the Bourne
+C<quotewords()> tries to interpret these characters just like the Bourne
shell). NB: these semantics are significantly different from the
original version of this module shipped with Perl 5.000 through 5.004.
+
+=item C<"delimiters">
+
As an additional feature, $keep may be the keyword "delimiters" which
causes the functions to preserve the delimiters in each string as
tokens in the token lists, in addition to preserving quote and
backslash characters.
-&shellwords() is written as a special case of &quotewords(), and it
+=back
+
+C<shellwords()> is written as a special case of C<quotewords()>, and it
does token parsing with whitespace as a delimiter-- similar to most
Unix shells.
@@ -280,20 +296,28 @@ L<Text::CSV> - for parsing CSV files
=head1 AUTHORS
-Maintainer: Alexandr Ciornii <alexchornyATgmail.com>.
+The original author is unknown,
+but presumably this evolved from C<shellwords.pl> in Perl 4.
+
+Much of the code for C<parse_line()>
+(including the primary regexp)
+came from Joerk Behrends E<lt>jbehrends@multimediaproduzenten.deE<gt>.
+
+Examples section and other documentation provided by
+John Heidemann E<lt>johnh@ISI.EDUE<gt>.
-Previous maintainer: Hal Pomeranz <pomeranz@netcom.com>, 1994-1997 (Original
-author unknown). Much of the code for &parse_line() (including the
-primary regexp) from Joerk Behrends <jbehrends@multimediaproduzenten.de>.
+Hal Pomeranz E<lt>pomeranz@netcom.comE<gt>
+maintained this from 1994 through 1999,
+and did the first CPAN release.
-Examples section another documentation provided by John Heidemann
-<johnh@ISI.EDU>
+Alexandr Ciornii E<lt>alexchornyATgmail.comE<gt>
+maintained this from 2008 to 2015.
-Bug reports, patches, and nagging provided by lots of folks-- thanks
-everybody! Special thanks to Michael Schwern <schwern@envirolink.org>
-for assuring me that a &nested_quotewords() would be useful, and to
-Jeff Friedl <jfriedl@yahoo-inc.com> for telling me not to worry about
-error-checking (sort of-- you had to be there).
+Many other people have contributed,
+with special thanks due to
+Michael Schwern E<lt>schwern@envirolink.orgE<gt>
+and
+Jeff Friedl E<lt>jfriedl@yahoo-inc.comE<gt>.
=head1 COPYRIGHT AND LICENSE
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Tabs.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Tabs.pm
index 07fe2b8b02..b6c826ded9 100644
--- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Tabs.pm
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Tabs.pm
@@ -1,44 +1,32 @@
-package Text::Tabs;
-
-require Exporter;
-
-@ISA = (Exporter);
-@EXPORT = qw(expand unexpand $tabstop);
+use strict; use warnings;
-use vars qw($VERSION $SUBVERSION $tabstop $debug);
-$VERSION = 2013.0523;
-$SUBVERSION = 'modern';
-
-use strict;
+package Text::Tabs;
-use 5.010_000;
+BEGIN { require Exporter; *import = \&Exporter::import }
-BEGIN {
- $tabstop = 8;
- $debug = 0;
-}
+our @EXPORT = qw( expand unexpand $tabstop );
-my $CHUNK = qr/\X/;
+our $VERSION = '2021.0814';
+our $SUBVERSION = 'modern'; # back-compat vestige
-sub _xlen (_) { scalar(() = $_[0] =~ /$CHUNK/g) }
-sub _xpos (_) { _xlen( substr( $_[0], 0, pos($_[0]) ) ) }
+our $tabstop = 8;
sub expand {
my @l;
my $pad;
for ( @_ ) {
+ defined or do { push @l, ''; next };
my $s = '';
for (split(/^/m, $_, -1)) {
- my $offs = 0;
- s{\t}{
- # this works on both 5.10 and 5.11
- $pad = $tabstop - (_xlen(${^PREMATCH}) + $offs) % $tabstop;
- # this works on 5.11, but fails on 5.10
- #XXX# $pad = $tabstop - (_xpos() + $offs) % $tabstop;
- $offs += $pad - 1;
- " " x $pad;
- }peg;
- $s .= $_;
+ my $offs;
+ for (split(/\t/, $_, -1)) {
+ if (defined $offs) {
+ $pad = $tabstop - $offs % $tabstop;
+ $s .= " " x $pad;
+ }
+ $s .= $_;
+ $offs = () = /\PM/g;
+ }
}
push(@l, $s);
}
@@ -56,21 +44,17 @@ sub unexpand
my $lastbit;
my $ts_as_space = " " x $tabstop;
for $x (@l) {
+ defined $x or next;
@lines = split("\n", $x, -1);
for $line (@lines) {
$line = expand($line);
- @e = split(/(${CHUNK}{$tabstop})/,$line,-1);
+ @e = split(/((?:\PM\pM*){$tabstop})/,$line,-1);
$lastbit = pop(@e);
$lastbit = ''
unless defined $lastbit;
$lastbit = "\t"
if $lastbit eq $ts_as_space;
for $_ (@e) {
- if ($debug) {
- my $x = $_;
- $x =~ s/\t/^I\t/gs;
- print "sub on '$x'\n";
- }
s/ +$/\t/;
}
$line = join('',@e, $lastbit);
@@ -82,22 +66,8 @@ sub unexpand
}
1;
-__END__
-
-sub expand
-{
- my (@l) = @_;
- for $_ (@l) {
- 1 while s/(^|\n)([^\t\n]*)(\t+)/
- $1. $2 . (" " x
- ($tabstop * length($3)
- - (length($2) % $tabstop)))
- /sex;
- }
- return @l if wantarray;
- return $l[0];
-}
+__END__
=head1 NAME
@@ -164,17 +134,6 @@ Instead of the shell's C<unexpand -a> command, use:
perl -MText::Tabs -n -e 'print unexpand $_'
-=head1 SUBVERSION
-
-This module comes in two flavors: one for modern perls (5.10 and above)
-and one for ancient obsolete perls. The version for modern perls has
-support for Unicode. The version for old perls does not. You can tell
-which version you have installed by looking at C<$Text::Tabs::SUBVERSION>:
-it is C<old> for obsolete perls and C<modern> for current perls.
-
-This man page is for the version for modern perls and so that's probably
-what you've got.
-
=head1 BUGS
Text::Tabs handles only tabs (C<"\t">) and combining characters (C</\pM/>). It doesn't
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Wrap.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Wrap.pm
index db0d15f610..eff0e717c4 100644
--- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Wrap.pm
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Text/Wrap.pm
@@ -1,42 +1,32 @@
+use strict; use warnings;
+
package Text::Wrap;
use warnings::register;
-require Exporter;
-
-@ISA = qw(Exporter);
-@EXPORT = qw(wrap fill);
-@EXPORT_OK = qw($columns $break $huge);
-$VERSION = 2013.0523;
-$SUBVERSION = 'modern';
+BEGIN { require Exporter; *import = \&Exporter::import }
-use 5.010_000;
+our @EXPORT = qw( wrap fill );
+our @EXPORT_OK = qw( $columns $break $huge );
-use vars qw($VERSION $SUBVERSION $columns $debug $break $huge $unexpand $tabstop $separator $separator2);
-use strict;
-
-BEGIN {
- $columns = 76; # <= screen width
- $debug = 0;
- $break = '(?=\s)\X';
- $huge = 'wrap'; # alternatively: 'die' or 'overflow'
- $unexpand = 1;
- $tabstop = 8;
- $separator = "\n";
- $separator2 = undef;
-}
+our $VERSION = '2021.0814';
+our $SUBVERSION = 'modern'; # back-compat vestige
-my $CHUNK = qr/\X/;
+our $columns = 76; # <= screen width
+our $break = '(?=\s)(?:\r\n|\PM\pM*)';
+our $huge = 'wrap'; # alternatively: 'die' or 'overflow'
+our $unexpand = 1;
+our $tabstop = 8;
+our $separator = "\n";
+our $separator2 = undef;
-sub _xlen(_) { scalar(() = $_[0] =~ /$CHUNK/g) }
-
-sub _xpos(_) { _xlen( substr( $_[0], 0, pos($_[0]) ) ) }
+sub _xlen { () = $_[0] =~ /\PM/g }
use Text::Tabs qw(expand unexpand);
sub wrap
{
- my ($ip, $xp, @t) = @_;
+ my ($ip, $xp, @t) = map +( defined $_ ? $_ : '' ), @_;
local($Text::Tabs::tabstop) = $tabstop;
my $r = "";
@@ -59,17 +49,17 @@ sub wrap
pos($t) = 0;
while ($t !~ /\G(?:$break)*\Z/gc) {
- if ($t =~ /\G((?:(?=[^\n])\X){0,$ll})($break|\n+|\z)/xmgc) {
+ if ($t =~ /\G((?:(?!\n)\PM\pM*){0,$ll})($break|\n+|\z)/xmgc) {
$r .= $unexpand
? unexpand($nl . $lead . $1)
: $nl . $lead . $1;
$remainder = $2;
- } elsif ($huge eq 'wrap' && $t =~ /\G((?:(?=[^\n])\X){$ll})/gc) {
+ } elsif ($huge eq 'wrap' && $t =~ /\G((?:(?!\n)\PM\pM*){$ll})/gc) {
$r .= $unexpand
? unexpand($nl . $lead . $1)
: $nl . $lead . $1;
$remainder = defined($separator2) ? $separator2 : $separator;
- } elsif ($huge eq 'overflow' && $t =~ /\G((?:(?=[^\n])\X)*?)($break|\n+|\z)/xmgc) {
+ } elsif ($huge eq 'overflow' && $t =~ /\G((?:(?!\n)\PM\pM*)*?)($break|\n+|\z)/xmgc) {
$r .= $unexpand
? unexpand($nl . $lead . $1)
: $nl . $lead . $1;
@@ -79,7 +69,7 @@ sub wrap
} elsif ($columns < 2) {
warnings::warnif "Increasing \$Text::Wrap::columns from $columns to 2";
$columns = 2;
- return ($ip, $xp, @t);
+ return @_;
} else {
die "This shouldn't happen";
}
@@ -94,23 +84,15 @@ sub wrap
}
$r .= $remainder;
- print "-----------$r---------\n" if $debug;
-
- print "Finish up with '$lead'\n" if $debug;
-
- my($opos) = pos($t);
-
$r .= $lead . substr($t, pos($t), length($t) - pos($t))
if pos($t) ne length($t);
- print "-----------$r---------\n" if $debug;;
-
return $r;
}
sub fill
{
- my ($ip, $xp, @raw) = @_;
+ my ($ip, $xp, @raw) = map +( defined $_ ? $_ : '' ), @_;
my @para;
my $pp;
@@ -128,6 +110,7 @@ sub fill
}
1;
+
__END__
=head1 NAME
@@ -269,17 +252,6 @@ Result:
"This is a bit of|text that forms a|normal book-style|paragraph"
-=head1 SUBVERSION
-
-This module comes in two flavors: one for modern perls (5.10 and above)
-and one for ancient obsolete perls. The version for modern perls has
-support for Unicode. The version for old perls does not. You can tell
-which version you have installed by looking at C<$Text::Wrap::SUBVERSION>:
-it is C<old> for obsolete perls and C<modern> for current perls.
-
-This man page is for the version for modern perls and so that's probably
-what you've got.
-
=head1 SEE ALSO
For correct handling of East Asian half- and full-width characters,