diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/B')
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Concise.pm | 12 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Debug.pm | 141 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Deparse.pm | 129 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Lint.pm | 6 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Lint/Debug.pm | 2 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Showlex.pm | 6 |
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 |