summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/B
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2012-05-21 00:15:27 +0000
committerKarl Berry <karl@freefriends.org>2012-05-21 00:15:27 +0000
commita4c42bfb2337d37da89d789cb8cc226367994e32 (patch)
treec3eabdef5d565a4e515d2be0d9d4d0540bde0250 /Master/tlpkg/tlperl/lib/B
parent8274475057f024d35332ac47c2e2f23ea156e6ed (diff)
perl 5.14.2 from siep
git-svn-id: svn://tug.org/texlive/trunk@26525 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/B')
-rw-r--r--Master/tlpkg/tlperl/lib/B/Concise.pm12
-rw-r--r--Master/tlpkg/tlperl/lib/B/Debug.pm141
-rw-r--r--Master/tlpkg/tlperl/lib/B/Deparse.pm129
-rw-r--r--Master/tlpkg/tlperl/lib/B/Lint.pm6
-rw-r--r--Master/tlpkg/tlperl/lib/B/Lint/Debug.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/B/Showlex.pm6
6 files changed, 159 insertions, 137 deletions
diff --git a/Master/tlpkg/tlperl/lib/B/Concise.pm b/Master/tlpkg/tlperl/lib/B/Concise.pm
index 26996058941..014a4df84d1 100644
--- a/Master/tlpkg/tlperl/lib/B/Concise.pm
+++ b/Master/tlpkg/tlperl/lib/B/Concise.pm
@@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp
use Exporter (); # use #5
-our $VERSION = "0.78";
+our $VERSION = "0.83";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw( set_style set_style_standard add_callback
concise_subref concise_cv concise_main
@@ -306,7 +306,7 @@ sub compileOpts {
if (!$Config::Config{usedl}
&& keys %{$pkg.'::'} == 1
&& $pkg->can('bootstrap')) {
- # It is something that we're staticly linked to, but hasn't
+ # It is something that we're statically linked to, but hasn't
# yet been used.
eval "require $pkg";
}
@@ -462,7 +462,7 @@ sub walk_topdown {
walk_topdown($kid, $sub, $level + 1);
}
}
- elsif (class($op) eq "PMOP") {
+ if (class($op) eq "PMOP") {
my $maybe_root = $op->pmreplroot;
if (ref($maybe_root) and $maybe_root->isa("B::OP")) {
# It really is the root of the replacement, not something
@@ -586,7 +586,7 @@ sub fmt_line { # generate text-line for op.
$text = "# $hr->{src}\n$text" if $show_src and $hr->{src};
chomp $text;
- return "$text\n" if $text ne "";
+ return "$text\n" if $text ne "" and $order ne "tree";
return $text; # suppress empty lines
}
@@ -604,8 +604,10 @@ $priv{"sassign"}{64} = "BKWARD";
$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont", "qr");
@{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
"COMPL", "GROWS");
+$priv{transr} = $priv{trans};
$priv{"repeat"}{64} = "DOLIST";
$priv{"leaveloop"}{64} = "CONT";
+$priv{$_}{4} = "DREFed" for (qw(rv2sv rv2av rv2hv));
@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
for (qw(rv2gv rv2sv padsv aelem helem));
$priv{$_}{16} = "STATE" for ("padav", "padhv", "padsv");
@@ -835,7 +837,7 @@ sub concise_op {
} else {
$h{arg} = "($precomp)";
}
- } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
+ } elsif ($h{class} eq "PVOP" and $h{name} !~ '^transr?\z') {
$h{arg} = '("' . $op->pv . '")';
$h{svval} = '"' . $op->pv . '"';
} elsif ($h{class} eq "COP") {
diff --git a/Master/tlpkg/tlperl/lib/B/Debug.pm b/Master/tlpkg/tlperl/lib/B/Debug.pm
index f44d59dd022..17f026d9fa8 100644
--- a/Master/tlpkg/tlperl/lib/B/Debug.pm
+++ b/Master/tlpkg/tlperl/lib/B/Debug.pm
@@ -1,23 +1,34 @@
package B::Debug;
-our $VERSION = '1.12';
+our $VERSION = '1.16';
use strict;
require 5.006;
use B qw(peekop class walkoptree walkoptree_exec
- main_start main_root cstring sv_undef);
+ main_start main_root cstring sv_undef SVf_NOK SVf_IOK);
use Config;
my (@optype, @specialsv_name);
require B;
if ($] < 5.009) {
require B::Asmdata;
- B::Asmdata->import qw(@optype @specialsv_name);
+ B::Asmdata->import (qw(@optype @specialsv_name));
} else {
- B->import qw(@optype @specialsv_name);
+ B->import (qw(@optype @specialsv_name));
}
-my $have_B_Flags;
+
+if ($] < 5.006002) {
+ eval q|sub B::GV::SAFENAME {
+ my $name = (shift())->NAME;
+ # The regex below corresponds to the isCONTROLVAR macro from toke.c
+ $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e;
+ return $name;
+ }|;
+}
+
+my ($have_B_Flags, $have_B_Flags_extra);
if (!$ENV{PERL_CORE}){ # avoid CORE test crashes
eval { require B::Flags and $have_B_Flags++ };
+ $have_B_Flags_extra++ if $have_B_Flags and $B::Flags::VERSION gt '0.03';
}
my %done_gv;
@@ -25,18 +36,18 @@ sub _printop {
my $op = shift;
my $addr = ${$op} ? $op->ppaddr : '';
$addr =~ s/^PL_ppaddr// if $addr;
- return sprintf "0x%x %s %s", ${$op}, ${$op} ? class($op) : '', $addr;
+ return sprintf "0x%08x %6s %s", ${$op}, ${$op} ? class($op) : '', $addr;
}
sub B::OP::debug {
my ($op) = @_;
- printf <<'EOT', class($op), $$op, $op->ppaddr, _printop($op->next), _printop($op->sibling), $op->targ, $op->type;
+ printf <<'EOT', class($op), $$op, _printop($op), _printop($op->next), _printop($op->sibling), $op->targ, $op->type, $op->name;
%s (0x%lx)
op_ppaddr %s
op_next %s
op_sibling %s
op_targ %d
- op_type %d
+ op_type %d %s
EOT
if ($] > 5.009) {
printf <<'EOT', $op->opt;
@@ -117,8 +128,8 @@ sub B::PMOP::debug {
sub B::COP::debug {
my ($op) = @_;
$op->B::OP::debug();
- my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
- printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
+ my $warnings = ref $op->warnings ? ${$op->warnings} : 0;
+ printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, $warnings;
cop_label "%s"
cop_stashpv "%s"
cop_file "%s"
@@ -126,8 +137,11 @@ sub B::COP::debug {
cop_arybase %d
cop_line %d
cop_warnings 0x%x
- cop_io %s
EOT
+ if ($] > 5.008 and $] < 5.011) {
+ my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
+ printf(" cop_io %s\n", cstring($cop_io));
+ }
}
sub B::SVOP::debug {
@@ -164,11 +178,16 @@ sub B::SV::debug {
print class($sv), " = NULL\n";
return;
}
- printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
+ printf <<'EOT', class($sv), $$sv, $sv->REFCNT;
%s (0x%x)
REFCNT %d
FLAGS 0x%x
EOT
+ printf "\tFLAGS\t\t0x%x", $sv->FLAGS;
+ if ($have_B_Flags) {
+ printf "\t%s", $have_B_Flags_extra ? $sv->flagspv(0) : $sv->flagspv;
+ }
+ print "\n";
}
sub B::RV::debug {
@@ -193,25 +212,25 @@ EOT
sub B::IV::debug {
my ($sv) = @_;
$sv->B::SV::debug();
- printf "\txiv_iv\t\t%d\n", $sv->IV;
+ printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
}
sub B::NV::debug {
my ($sv) = @_;
$sv->B::IV::debug();
- printf "\txnv_nv\t\t%s\n", $sv->NV;
+ printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
}
sub B::PVIV::debug {
my ($sv) = @_;
$sv->B::PV::debug();
- printf "\txiv_iv\t\t%d\n", $sv->IV;
+ printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
}
sub B::PVNV::debug {
my ($sv) = @_;
$sv->B::PVIV::debug();
- printf "\txnv_nv\t\t%s\n", $sv->NV;
+ printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
}
sub B::PVLV::debug {
@@ -235,11 +254,11 @@ sub B::CV::debug {
$sv->B::PVNV::debug();
my ($stash) = $sv->STASH;
my ($start) = $sv->START;
- my ($root) = $sv->ROOT;
+ my ($root) = $sv->ROOT;
my ($padlist) = $sv->PADLIST;
my ($file) = $sv->FILE;
my ($gv) = $sv->GV;
- printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
+ printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
STASH 0x%x
START 0x%x
ROOT 0x%x
@@ -248,8 +267,15 @@ sub B::CV::debug {
DEPTH %d
PADLIST 0x%x
OUTSIDE 0x%x
- OUTSIDE_SEQ %d
EOT
+ printf("\tOUTSIDE_SEQ\t%d\n", , $sv->OUTSIDE_SEQ) if $] > 5.007;
+ if ($have_B_Flags) {
+ my $SVt_PVCV = $] < 5.010 ? 12 : 13;
+ printf("\tCvFLAGS\t0x%x\t%s\n", $sv->CvFLAGS,
+ $have_B_Flags_extra ? $sv->flagspv($SVt_PVCV) : $sv->flagspv);
+ } else {
+ printf("\tCvFLAGS\t0x%x\n", $sv->CvFLAGS);
+ }
$start->debug if $start;
$root->debug if $root;
$gv->debug if $gv;
@@ -275,9 +301,14 @@ EOT
MAX %d
EOT
}
- printf <<'EOT', $av->AvFLAGS if $] < 5.009;
- AvFLAGS %d
-EOT
+ if ($] < 5.009) {
+ if ($have_B_Flags) {
+ printf("\tAvFLAGS\t0x%x\t%s\n", $av->AvFLAGS,
+ $have_B_Flags_extra ? $av->flagspv(10) : $av->flagspv);
+ } else {
+ printf("\tAvFLAGS\t0x%x\n", $av->AvFLAGS);
+ }
+ }
}
sub B::GV::debug {
@@ -286,9 +317,9 @@ sub B::GV::debug {
printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
return;
}
- my ($sv) = $gv->SV;
- my ($av) = $gv->AV;
- my ($cv) = $gv->CV;
+ my $sv = $gv->SV;
+ my $av = $gv->AV;
+ my $cv = $gv->CV;
$gv->B::SV::debug;
printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS;
NAME %s
@@ -303,8 +334,14 @@ sub B::GV::debug {
CVGEN %d
LINE %d
FILE %s
- GvFLAGS 0x%x
EOT
+ if ($have_B_Flags) {
+ my $SVt_PVGV = $] < 5.010 ? 13 : 9;
+ printf("\tGvFLAGS\t0x%x\t%s\n", $gv->GvFLAGS,
+ $have_B_Flags_extra ? $gv->flagspv($SVt_PVGV) : $gv->flagspv);
+ } else {
+ printf("\tGvFLAGS\t0x%x\n", $gv->GvFLAGS);
+ }
$sv->debug if $sv;
$av->debug if $av;
$cv->debug if $cv;
@@ -312,7 +349,8 @@ EOT
sub B::SPECIAL::debug {
my $sv = shift;
- print $specialsv_name[$$sv], "\n";
+ my $i = ref $sv ? $$sv : 0;
+ print exists $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n";
}
sub compile {
@@ -335,7 +373,8 @@ B::Debug - Walk Perl syntax tree, printing debug info about ops
=head1 SYNOPSIS
- perl -MO=Debug[,OPTIONS] foo.pl
+ perl -MO=Debug foo.pl
+ perl -MO=Debug,-exec foo.pl
=head1 DESCRIPTION
@@ -346,50 +385,6 @@ See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
With option -exec, walks tree in execute order,
otherwise in basic order.
-=head1 Changes
-
- 1.12 2010-02-10 rurban
- remove archlib installation cruft, and use the proper PM rule.
- By Todd Rinaldo (toddr)
-
- 1.11 2008-07-14 rurban
- avoid B::Flags in CORE tests not to crash on old XS in @INC
-
- 1.10 2008-06-28 rurban
- require 5.006; Test::More not possible in 5.00505
- our => my
-
- 1.09 2008-06-18 rurban
- minor META.yml syntax fix
- 5.8.0 ending nextstate test failure: be more tolerant
- PREREQ_PM Test::More
-
- 1.08 2008-06-17 rurban
- support 5.00558 - 5.6.2
-
- 1.07 2008-06-16 rurban
- debug.t: fix strawberry perl quoting issue
-
- 1.06 2008-06-11 rurban
- added B::Flags output
- dual-life CPAN as B-Debug-1.06 and CORE
- protect scalar(@array) if tied arrays leave out FETCHSIZE
-
- 1.05_03 2008-04-16 rurban
- ithread fixes in B::AV
- B-C-1.04_??
-
- B-C-1.04_09 2008-02-24 rurban
- support 5.8 (import Asmdata)
-
- 1.05_02 2008-02-21 rurban
- added _printop
- B-C-1.04_08 and CORE
-
- 1.05_01 2008-02-05 rurban
- 5.10 fix for op->seq
- B-C-1.04_04
-
=head1 AUTHOR
Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
@@ -398,7 +393,7 @@ Reini Urban C<rurban@cpan.org>
=head1 LICENSE
Copyright (c) 1996, 1997 Malcolm Beattie
-Copyright (c) 2008 Reini Urban
+Copyright (c) 2008, 2010 Reini Urban
This program is free software; you can redistribute it and/or modify
it under the terms of either:
diff --git a/Master/tlpkg/tlperl/lib/B/Deparse.pm b/Master/tlpkg/tlperl/lib/B/Deparse.pm
index b8e220e8e5c..f3c304f8263 100644
--- a/Master/tlpkg/tlperl/lib/B/Deparse.pm
+++ b/Master/tlpkg/tlperl/lib/B/Deparse.pm
@@ -11,34 +11,42 @@ package B::Deparse;
use Carp;
use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
- OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPpPAD_STATE
+ OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
- OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED
- OPpREVERSE_INPLACE OPpCONST_NOVER
+ OPpSORT_REVERSE
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
CVf_METHOD CVf_LVALUE
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED),
- ($] < 5.009 ? 'PMf_SKIPWHITE' : 'RXf_SKIPWHITE'),
- ($] < 5.011 ? 'CVf_LOCKED' : ());
-$VERSION = 0.97_01;
+ ($] < 5.008004 ? () : 'OPpSORT_INPLACE'),
+ ($] < 5.008006 ? () : qw(OPpSORT_DESCEND OPpITER_REVERSED)),
+ ($] < 5.008009 ? () : qw(OPpCONST_NOVER OPpPAD_STATE)),
+ ($] < 5.009 ? 'PMf_SKIPWHITE' : qw(RXf_SKIPWHITE)),
+ ($] < 5.011 ? 'CVf_LOCKED' : 'OPpREVERSE_INPLACE'),
+ ($] < 5.013 ? () : 'PMf_NONDESTRUCT');
+$VERSION = "1.04";
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
BEGIN {
- # Easiest way to keep this code portable between 5.12.x and 5.10.x looks to
- # be to fake up a dummy CVf_LOCKED that will never actually be true.
- *CVf_LOCKED = sub () {0} unless defined &CVf_LOCKED;
+ # Easiest way to keep this code portable between version looks to
+ # be to fake up a dummy constant that will never actually be true.
+ foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
+ OPpPAD_STATE RXf_SKIPWHITE CVf_LOCKED OPpREVERSE_INPLACE
+ PMf_NONDESTRUCT)) {
+ no strict 'refs';
+ *{$_} = sub () {0} unless *{$_}{CODE};
+ }
}
# Changes between 0.50 and 0.51:
# - fixed nulled leave with live enter in sort { }
# - fixed reference constants (\"str")
# - handle empty programs gracefully
-# - handle infinte loops (for (;;) {}, while (1) {})
+# - handle infinite loops (for (;;) {}, while (1) {})
# - differentiate between `for my $x ...' and `my $x; for $x ...'
# - various minor cleanups
# - moved globals into an object
@@ -98,10 +106,10 @@ BEGIN {
# - added support for Ilya's OPpTARGET_MY optimization
# - elided arrows before `()' subscripts when possible
# Changes between 0.59 and 0.60
-# - support for method attribues was added
+# - support for method attributes was added
# - some warnings fixed
# - separate recognition of constant subs
-# - rewrote continue block handling, now recoginizing for loops
+# - rewrote continue block handling, now recognizing for loops
# - added more control of expanding control structures
# Changes between 0.60 and 0.61 (mostly by Robin Houston)
# - many bug-fixes
@@ -159,7 +167,7 @@ BEGIN {
# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
# op/getpid 2 - can't assign to shared my() declaration (threads only)
# 'my $x : shared = 5'
-# op/override 7 - parens on overriden require change v-string interpretation
+# op/override 7 - parens on overridden require change v-string interpretation
# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
# c.f. 'BEGIN { *f = sub {0} }; f 2'
# op/pat 774 - losing Unicode-ness of Latin1-only strings
@@ -472,7 +480,7 @@ sub stash_subs {
else {
$pack =~ s/(::)?$/::/;
no strict 'refs';
- $stash = \%$pack;
+ $stash = \%{"main::$pack"};
}
my %stash = svref_2object($stash)->ARRAY;
while (my ($key, $val) = each %stash) {
@@ -958,14 +966,19 @@ sub is_for_loop {
my $op = shift;
# This OP might be almost anything, though it won't be a
# nextstate. (It's the initialization, so in the canonical case it
- # will be an sassign.) The sibling is a lineseq whose first child
- # is a nextstate and whose second is a leaveloop.
+ # will be an sassign.) The sibling is (old style) a lineseq whose
+ # first child is a nextstate and whose second is a leaveloop, or
+ # (new style) an unstack whose sibling is a leaveloop.
my $lseq = $op->sibling;
- if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") {
+ return 0 unless !is_state($op) and !null($lseq);
+ if ($lseq->name eq "lineseq") {
if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
&& (my $sib = $lseq->first->sibling)) {
return (!null($sib) && $sib->name eq "leaveloop");
}
+ } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) {
+ my $sib = $lseq->sibling;
+ return $sib && !null($sib) && $sib->name eq "leaveloop";
}
return 0;
}
@@ -1041,9 +1054,11 @@ sub maybe_local {
and not $self->{'avoid_local'}{$$op}) {
my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
if( $our_local eq 'our' ) {
- # XXX This assertion fails code with non-ASCII identifiers,
- # like ./ext/Encode/t/jperl.t
- die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/;
+ if ( $text !~ /^\W(\w+::)*\w+\z/
+ and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
+ ) {
+ die "Unexpected our($text)\n";
+ }
$text =~ s/(\w+::)+//;
}
if (want_scalar($op)) {
@@ -1213,7 +1228,8 @@ sub walk_lineseq {
}
}
if (is_for_loop($kids[$i])) {
- $callback->($expr . $self->for_loop($kids[$i], 0), $i++);
+ $callback->($expr . $self->for_loop($kids[$i], 0),
+ $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
next;
}
$expr .= $self->deparse($kids[$i], (@kids != 1)/2);
@@ -1412,9 +1428,10 @@ sub pp_nextstate {
$self->{'warnings'} = $warning_bits;
}
- if ($self->{'hints'} != $op->hints) {
- push @text, declare_hints($self->{'hints'}, $op->hints);
- $self->{'hints'} = $op->hints;
+ my $hints = $] < 5.008009 ? $op->private : $op->hints;
+ if ($self->{'hints'} != $hints) {
+ push @text, declare_hints($self->{'hints'}, $hints);
+ $self->{'hints'} = $hints;
}
# hack to check that the hint hash hasn't changed
@@ -2387,6 +2404,9 @@ sub pp_syscall { listop(@_, "syscall") }
sub pp_glob {
my $self = shift;
my($op, $cx) = @_;
+ if ($op->flags & OPf_SPECIAL) {
+ return $self->deparse($op->first->sibling);
+ }
my $text = $self->dq($op->first->sibling); # skip pushmark
if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
or $text =~ /[<>]/) {
@@ -2675,7 +2695,8 @@ sub loop_common {
$ary = $self->deparse($ary, 1);
}
if (null $var) {
- if ($enter->flags & OPf_SPECIAL) { # thread special var
+ if (($enter->flags & OPf_SPECIAL) && ($] < 5.009)) {
+ # thread special var, under 5005threads
$var = $self->pp_threadsv($enter, 1);
} else { # regular my() variable
$var = $self->pp_padsv($enter, 1);
@@ -2755,7 +2776,9 @@ sub for_loop {
my $self = shift;
my($op, $cx) = @_;
my $init = $self->deparse($op, 1);
- return $self->loop_common($op->sibling->first->sibling, $cx, $init);
+ my $s = $op->sibling;
+ my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling;
+ return $self->loop_common($ll, $cx, $init);
}
sub pp_leavetry {
@@ -2832,15 +2855,7 @@ sub pp_padsv {
sub pp_padav { pp_padsv(@_) }
sub pp_padhv { pp_padsv(@_) }
-my @threadsv_names;
-
-BEGIN {
- @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
- "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
- "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
- "!", "@");
-}
-
+my @threadsv_names = B::threadsv_names;
sub pp_threadsv {
my $self = shift;
my($op, $cx) = @_;
@@ -3381,14 +3396,6 @@ sub pp_entersub {
return $prefix . $amper. $kid;
}
} else {
- # glob() invocations can be translated into calls of
- # CORE::GLOBAL::glob with a second parameter, a number.
- # Reverse this.
- if ($kid eq "CORE::GLOBAL::glob") {
- $kid = "glob";
- $args =~ s/\s*,[^,]+$//;
- }
-
# It's a syntax error to call CORE::GLOBAL::foo without a prefix,
# so it must have been translated from a keyword call. Translate
# it back.
@@ -4075,19 +4082,26 @@ sub pp_trans {
my $self = shift;
my($op, $cx) = @_;
my($from, $to);
- if (class($op) eq "PVOP") {
- ($from, $to) = tr_decode_byte($op->pv, $op->private);
+ my $class = class($op);
+ my $priv_flags = $op->private;
+ if ($class eq "PVOP") {
+ ($from, $to) = tr_decode_byte($op->pv, $priv_flags);
+ } elsif ($class eq "PADOP") {
+ ($from, $to)
+ = tr_decode_utf8($self->padval($op->padix)->RV, $priv_flags);
} else { # class($op) eq "SVOP"
- ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
+ ($from, $to) = tr_decode_utf8($op->sv->RV, $priv_flags);
}
my $flags = "";
- $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
- $flags .= "d" if $op->private & OPpTRANS_DELETE;
+ $flags .= "c" if $priv_flags & OPpTRANS_COMPLEMENT;
+ $flags .= "d" if $priv_flags & OPpTRANS_DELETE;
$to = "" if $from eq $to and $flags eq "";
- $flags .= "s" if $op->private & OPpTRANS_SQUASH;
+ $flags .= "s" if $priv_flags & OPpTRANS_SQUASH;
return "tr" . double_delim($from, $to) . $flags;
}
+sub pp_transr { &pp_trans . 'r' }
+
sub re_dq_disambiguate {
my ($first, $last) = @_;
# Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
@@ -4221,6 +4235,7 @@ sub matchop {
}
my $quote = 1;
my $extended = ($op->pmflags & PMf_EXTENDED);
+ my $rhs_bound_to_defsv;
if (null $kid) {
my $unbacked = re_unback($op->precomp);
if ($extended) {
@@ -4232,6 +4247,7 @@ sub matchop {
carp("found ".$kid->name." where regcomp expected");
} else {
($re, $quote) = $self->regcomp($kid, 21, $extended);
+ $rhs_bound_to_defsv = 1 if $kid->first->first->flags & OPf_SPECIAL;
}
my $flags = "";
$flags .= "c" if $op->pmflags & PMf_CONTINUE;
@@ -4250,7 +4266,13 @@ sub matchop {
}
$re = $re . $flags if $quote;
if ($binop) {
- return $self->maybe_parens("$var =~ $re", $cx, 20);
+ return
+ $self->maybe_parens(
+ $rhs_bound_to_defsv
+ ? "$var =~ (\$_ =~ $re)"
+ : "$var =~ $re",
+ $cx, 20
+ );
} else {
return $re;
}
@@ -4310,7 +4332,9 @@ my %substwords;
map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
- 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
+ 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi',
+ 'sir', 'rise', 'smore', 'more', 'seer', 'rome', 'gore', 'grim', 'grime',
+ 'or', 'rose', 'rosie');
sub pp_subst {
my $self = shift;
@@ -4351,6 +4375,7 @@ sub pp_subst {
($re) = $self->regcomp($kid, 1, $extended);
}
$flags .= "e" if $op->pmflags & PMf_EVAL;
+ $flags .= "r" if $op->pmflags & PMf_NONDESTRUCT;
$flags .= "g" if $op->pmflags & PMf_GLOBAL;
$flags .= "i" if $op->pmflags & PMf_FOLD;
$flags .= "m" if $op->pmflags & PMf_MULTILINE;
@@ -4855,7 +4880,7 @@ which is not, consequently, deparsed correctly.
Lexical (my) variables declared in scopes external to a subroutine
appear in code2ref output text as package variables. This is a tricky
-problem, as perl has no native facility for refering to a lexical variable
+problem, as perl has no native facility for referring to a lexical variable
defined within a different scope, although L<PadWalker> is a good start.
=item *
diff --git a/Master/tlpkg/tlperl/lib/B/Lint.pm b/Master/tlpkg/tlperl/lib/B/Lint.pm
index b039215ad75..a38ee323d0d 100644
--- a/Master/tlpkg/tlperl/lib/B/Lint.pm
+++ b/Master/tlpkg/tlperl/lib/B/Lint.pm
@@ -1,6 +1,6 @@
package B::Lint;
-our $VERSION = '1.11_01'; ## no critic
+our $VERSION = '1.13'; ## no critic
=head1 NAME
@@ -584,7 +584,7 @@ PRIVATE_NAMES: {
DOLLAR_UNDERSCORE: {
# Warn on uses of $_ with a few exceptions. I'm not warning on
- # $_ inside grep, map, or statement modifer foreach because
+ # $_ inside grep, map, or statement modifier foreach because
# they localize $_ and it'd be impossible to use these
# features without getting warnings.
@@ -626,7 +626,7 @@ UNDEFINED_SUBS: {
no strict 'refs'; ## no critic strict
if ( not exists &$subname ) {
$subname =~ s/\Amain:://;
- warning q[Nonexistant subroutine '%s' called], $subname;
+ warning q[Nonexistent subroutine '%s' called], $subname;
}
elsif ( not defined &$subname ) {
$subname =~ s/\A\&?main:://;
diff --git a/Master/tlpkg/tlperl/lib/B/Lint/Debug.pm b/Master/tlpkg/tlperl/lib/B/Lint/Debug.pm
index 5929bb6d428..1a4bf31f7f6 100644
--- a/Master/tlpkg/tlperl/lib/B/Lint/Debug.pm
+++ b/Master/tlpkg/tlperl/lib/B/Lint/Debug.pm
@@ -1,6 +1,6 @@
package B::Lint::Debug;
-our $VERSION = '0.01';
+our $VERSION = '1.12';
=head1 NAME
diff --git a/Master/tlpkg/tlperl/lib/B/Showlex.pm b/Master/tlpkg/tlperl/lib/B/Showlex.pm
index 3b261a337df..2de8aa49b28 100644
--- a/Master/tlpkg/tlperl/lib/B/Showlex.pm
+++ b/Master/tlpkg/tlperl/lib/B/Showlex.pm
@@ -1,6 +1,6 @@
package B::Showlex;
-our $VERSION = '1.02';
+our $VERSION = '1.03';
use strict;
use B qw(svref_2object comppadlist class);
@@ -188,8 +188,8 @@ your declared lexicals.
=head1 SEE ALSO
-C<B::Showlex> can also be used outside of the O framework, as in the third
-example. See C<B::Concise> for a fuller explanation of reasons.
+L<B::Showlex> can also be used outside of the O framework, as in the third
+example. See L<B::Concise> for a fuller explanation of reasons.
=head1 TODO