diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/B')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/B/Concise.pm | 153 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/B/Debug.pm | 20 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/B/Deparse.pm | 113 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/B/Lint.pm | 793 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/B/Lint/Debug.pm | 73 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/B/Showlex.pm | 4 |
6 files changed, 168 insertions, 988 deletions
diff --git a/Master/tlpkg/tlperl/lib/B/Concise.pm b/Master/tlpkg/tlperl/lib/B/Concise.pm index 59d11272a13..6c818a4e463 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.95_01"; +our $VERSION = "0.992"; our @ISA = qw(Exporter); our @EXPORT_OK = qw( set_style set_style_standard add_callback concise_subref concise_cv concise_main @@ -46,7 +46,8 @@ my %style = "gt_#seq ", "(?(#seq)?)#noise#arg(?([#targarg])?)"], "debug" => - ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t" + ["#class (#addr)\n\top_next\t\t#nextaddr\n\t(?(op_other\t#otheraddr\n\t)?)" + . "op_sibling\t#sibaddr\n\t" . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" . "\top_flags\t#flagval\n\top_private\t#privval\t#hintsval\n" . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)" @@ -594,75 +595,70 @@ sub fmt_line { # generate text-line for op. our %priv; # used to display each opcode's BASEOP.op_private values $priv{$_}{128} = "LVINTRO" - for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv", - "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv", - "padav", "padhv", "enteriter", "entersub", "padrange", "pushmark"); -$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite"); -$priv{"aassign"}{64} = "COMMON"; -$priv{"aassign"}{32} = "STATE"; -$priv{"sassign"}{32} = "STATE"; -$priv{"sassign"}{64} = "BKWARD"; -$priv{"sassign"}{128}= "CV2GV"; -$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"); -@{$priv{rv2gv}}{4,16} = qw "NOINIT FAKE"; -@{$priv{"entersub"}}{1,4,16,32,64} = qw( INARGS TARG DBG DEREF ); -@{$priv{rv2cv}}{1,8,128} = ("CONST","AMPER","NO()"); -$priv{"gv"}{32} = "EARLYCV"; -$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER"; -$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv", - "enteriter"); -$priv{$_}{8} = 'LVSUB' for qw(rv2av rv2gv rv2hv padav padhv aelem helem - aslice hslice av2arylen keys rkeys substr pos vec); -@{$priv{$_}}{32,64} = ('BOOL','BOOL?') for 'rv2hv', 'padhv'; -$priv{substr}{16} = 'REPL1ST'; + for qw(pos substr vec threadsv gvsv rv2sv rv2hv rv2gv rv2av rv2arylen + aelem helem aslice hslice padsv padav padhv enteriter entersub + padrange pushmark); +$priv{$_}{64} = "REFC" for qw(leave leavesub leavesublv leavewrite); +$priv{$_}{128} = "LV" for qw(leave leaveloop); +@{$priv{aassign}}{32,64} = qw(STATE COMMON); +@{$priv{sassign}}{32,64,128} = qw(STATE BKWARD CV2GV); +$priv{$_}{64} = "RTIME" for qw(match subst substcont qr); +@{$priv{$_}}{1,2,4,8,16,64} = qw(<UTF >UTF IDENT SQUASH DEL COMPL GROWS) + for qw(trans transr); +$priv{repeat}{64} = "DOLIST"; +$priv{leaveloop}{64} = "CONT"; +@{$priv{$_}}{32,64,96} = qw(DREFAV DREFHV DREFSV) + for qw(rv2gv rv2sv padsv aelem helem); +$priv{$_}{16} = "STATE" for qw(padav padhv padsv); +@{$priv{rv2gv}}{4,16} = qw(NOINIT FAKE); +@{$priv{entersub}}{1,4,16,32,64} = qw(INARGS TARG DBG DEREF); +@{$priv{rv2cv}}{1,8,128} = qw(CONST AMPER NO()); +$priv{gv}{32} = "EARLYCV"; +$priv{$_}{16} = "LVDEFER" for qw(aelem helem); +$priv{$_}{16} = "OURINTR" for qw(gvsv rv2sv rv2av rv2hv r2gv enteriter); +$priv{$_}{8} = "LVSUB" + for qw(rv2av rv2gv rv2hv padav padhv aelem helem aslice hslice + av2arylen keys rkeys substr pos vec); +$priv{$_}{4} = "SLICEWARN" + for qw(rv2hv rv2av padav padhv hslice aslice); +@{$priv{$_}}{32,64} = qw(BOOL BOOL?) for qw(rv2hv padhv); +$priv{substr}{16} = "REPL1ST"; $priv{$_}{16} = "TARGMY" - for (map(($_,"s$_"),"chop", "chomp"), - map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo", - "add", "subtract", "negate"), "pow", "concat", "stringify", - "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or", - "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt", - "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf", - "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock", - "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename", - "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system", - "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority", - "setpriority", "time", "sleep"); -$priv{$_}{4} = "REVERSED" for ("enteriter", "iter"); -@{$priv{"const"}}{2,4,8,16,64,128} = - ("NOVER","SHORT","STRICT","ENTERED","BARE","FOLD"); -$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM"; -$priv{"list"}{64} = "GUESSED"; -$priv{"delete"}{64} = "SLICE"; -$priv{"exists"}{64} = "SUB"; -@{$priv{"sort"}}{1,2,4,8,16,32,64} = ("NUM", "INT", "REV", "INPLACE","DESC","QSORT","STABLE"); -$priv{"reverse"}{8} = "INPLACE"; -$priv{"threadsv"}{64} = "SVREFd"; -@{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR") - for ("open", "backtick"); -$priv{"exit"}{128} = "VMS"; + for map(($_,"s$_"), qw(chop chomp)), + map(($_,"i_$_"), qw(postinc postdec multiply divide modulo add + subtract negate)), + qw(pow concat stringify left_shift right_shift bit_and bit_xor + bit_or complement atan2 sin cos rand exp log sqrt int hex oct + abs length index rindex sprintf ord chr crypt quotemeta join + push unshift flock chdir chown chroot unlink chmod utime rename + link symlink mkdir rmdir wait waitpid system exec kill getppid + getpgrp setpgrp getpriority setpriority time sleep); +$priv{$_}{4} = "REVERSED" for qw(enteriter iter); +@{$priv{const}}{2,4,8,16,64} = qw(NOVER SHORT STRICT ENTERED BARE); +$priv{$_}{64} = "LINENUM" for qw(flip flop); +$priv{list}{64} = "GUESSED"; +$priv{delete}{64} = "SLICE"; +$priv{exists}{64} = "SUB"; +@{$priv{sort}}{1,2,4,8,16,32,64} = qw(NUM INT REV INPLACE DESC QSORT STABLE); +$priv{reverse}{8} = "INPLACE"; +$priv{threadsv}{64} = "SVREFd"; +@{$priv{$_}}{16,32,64,128} = qw(INBIN INCR OUTBIN OUTCR) + for qw(open backtick); +$priv{$_}{32} = "HUSH" for qw(nextstate dbstate); $priv{$_}{2} = "FTACCESS" - for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec"); -@{$priv{"entereval"}}{2,4,8,16} = qw "HAS_HH UNI BYTES COPHH"; -@{$priv{$_}}{4,8,16} = ("FTSTACKED","FTSTACKING","FTAFTERt") -for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec", - "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime", - "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir", - "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext", - "ftbinary"); + for qw(ftrread ftrwrite ftrexec fteread ftewrite fteexec); +@{$priv{entereval}}{2,4,8,16} = qw(HAS_HH UNI BYTES COPHH); +@{$priv{$_}}{4,8,16} = qw(FTSTACKED FTSTACKING FTAFTERt) + for qw(ftrread ftrwrite ftrexec fteread ftewrite fteexec ftis fteowned + ftrowned ftzero ftsize ftmtime ftatime ftctime ftsock ftchr + ftblk ftfile ftdir ftpipe ftlink ftsuid ftsgid ftsvtx fttty + fttext ftbinary); $priv{$_}{2} = "GREPLEX" -for ("mapwhile", "mapstart", "grepwhile", "grepstart"); -$priv{$_}{128} = '+1' for qw "caller wantarray runcv"; -@{$priv{coreargs}}{1,2,64,128} = ('DREF1','DREF2','$MOD','MARK'); -$priv{$_}{128} = 'UTF' for qw "last redo next goto dump"; + for qw(mapwhile mapstart grepwhile grepstart); +$priv{$_}{128} = "+1" for qw(caller wantarray runcv); +@{$priv{coreargs}}{1,2,64,128} = qw(DREF1 DREF2 $MOD MARK); +$priv{$_}{128} = "UTF" for qw(last redo next goto dump); +$priv{split}{128} = "IMPLIM"; our %hints; # used to display each COP's op_hints values @@ -891,6 +887,7 @@ sub concise_op { } elsif ($h{class} eq "LOGOP") { undef $lastnext; $h{arg} = "(other->" . seq($op->other) . ")"; + $h{otheraddr} = sprintf("%#x", $ {$op->other}); } elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") { unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) { @@ -921,6 +918,10 @@ sub concise_op { $h{flags} = op_flags($op->flags); $h{privval} = $op->private; $h{private} = private_flags($h{name}, $op->private); + if ($op->folded) { + $h{private} &&= "$h{private},"; + $h{private} .= "FOLD"; + } if ($op->can("hints")) { $h{hintsval} = $op->hints; $h{hints} = hints_flags($h{hintsval}); @@ -1643,7 +1644,7 @@ your program is). =item B<#opt> -Whether or not the op has been optimised by the peephole optimiser. +Whether or not the op has been optimized by the peephole optimizer. Only available in 5.9 and later. @@ -1810,13 +1811,13 @@ B<walk_output> lets you change the print destination from STDOUT to another open filehandle, or into a string passed as a ref (unless you've built perl with -Uuseperlio). - my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1 - walk_output(\my $buf); - $walker->(); # 1 renders -terse - set_style_standard('concise'); # 2 - $walker->(); # 2 renders -concise - $walker->(@new); # 3 renders whatever - print "3 different renderings: terse, concise, and @new: $buf\n"; + my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1 + walk_output(\my $buf); + $walker->(); # 1 renders -terse + set_style_standard('concise'); # 2 + $walker->(); # 2 renders -concise + $walker->(@new); # 3 renders whatever + print "3 different renderings: terse, concise, and @new: $buf\n"; When $walker is called, it traverses the subroutines supplied when it was created, and renders them using the current style. You can change diff --git a/Master/tlpkg/tlperl/lib/B/Debug.pm b/Master/tlpkg/tlperl/lib/B/Debug.pm index 31b0e2834be..c4a1a33afa6 100644 --- a/Master/tlpkg/tlperl/lib/B/Debug.pm +++ b/Master/tlpkg/tlperl/lib/B/Debug.pm @@ -1,6 +1,6 @@ package B::Debug; -our $VERSION = '1.18'; +our $VERSION = '1.19'; use strict; require 5.006; @@ -181,7 +181,6 @@ sub B::SV::debug { 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) { @@ -203,9 +202,10 @@ sub B::PV::debug { my ($sv) = @_; $sv->B::SV::debug(); my $pv = $sv->PV(); - printf <<'EOT', cstring($pv), length($pv); + printf <<'EOT', cstring($pv), $sv->CUR, $sv->LEN; xpv_pv %s xpv_cur %d + xpv_len %d EOT } @@ -258,17 +258,23 @@ sub B::CV::debug { my ($padlist) = $sv->PADLIST; my ($file) = $sv->FILE; my ($gv) = $sv->GV; - printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}; + printf <<'EOT', $$stash, $$start, $$root; STASH 0x%x START 0x%x ROOT 0x%x - GV 0x%x +EOT + if ( $]>5.017 && ($sv->FLAGS & 0x40000)) { #lexsub + printf("\tNAME\t%%s\n", $sv->NAME); + } else { + printf("\tGV\t%0x%x\t%s\n", $$gv, $gv->SAFENAME); + } + printf <<'EOT', $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}; FILE %s DEPTH %d PADLIST 0x%x OUTSIDE 0x%x EOT - printf("\tOUTSIDE_SEQ\t%d\n", , $sv->OUTSIDE_SEQ) if $] > 5.007; + 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, @@ -407,7 +413,7 @@ Reini Urban C<rurban@cpan.org> =head1 LICENSE Copyright (c) 1996, 1997 Malcolm Beattie -Copyright (c) 2008, 2010 Reini Urban +Copyright (c) 2008, 2010, 2013 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 d62fe3bc5fe..e7eb8cf90d3 100644 --- a/Master/tlpkg/tlperl/lib/B/Deparse.pm +++ b/Master/tlpkg/tlperl/lib/B/Deparse.pm @@ -20,7 +20,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring CVf_METHOD CVf_LVALUE PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = '1.20'; +$VERSION = '1.26'; use strict; use vars qw/$AUTOLOAD/; use warnings (); @@ -249,6 +249,9 @@ BEGIN { # subs_deparsed # Keeps track of fully qualified names of all deparsed subs. # +# in_subst_repl +# True when deparsing the replacement part of a substitution. +# # parens: -p # linenums: -l # unquote: -q @@ -313,6 +316,9 @@ BEGIN { +BEGIN { for (qw[ const stringify rv2sv list glob pushmark null]) { + eval "sub OP_\U$_ () { " . opnumber($_) . "}" +}} # _pessimise_walk(): recursively walk the optree of a sub, # possibly undoing optimisations along the way. @@ -342,6 +348,7 @@ sub _pessimise_walk { # the original gv[_]. $B::overlay->{$$op} = { + type => OP_PUSHMARK, name => 'pushmark', private => ($op->private & OPpLVAL_INTRO), next => ($op->flags & OPf_SPECIAL) @@ -401,7 +408,7 @@ sub _pessimise_walk_exe { } } -# Go through an optree and and "remove" some optimisations by using an +# Go through an optree and "remove" some optimisations by using an # overlay to selectively modify or un-null some ops. Deparsing in the # absence of those optimisations is then easier. # @@ -972,6 +979,9 @@ sub indent { } $line = substr($line, 1); } + if (index($line, "\f") > 0) { + $line =~ s/\f/\n/; + } if (substr($line, 0, 1) eq "\f") { $line = substr($line, 1); # no indent } else { @@ -1226,12 +1236,12 @@ sub padname_sv { sub maybe_my { my $self = shift; - my($op, $cx, $text) = @_; + my($op, $cx, $text, $forbid_parens) = @_; if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { my $my = $op->private & OPpPAD_STATE ? $self->keyword("state") : "my"; - if (want_scalar($op)) { + if ($forbid_parens || want_scalar($op)) { return "$my $text"; } else { return $self->maybe_parens_func($my, $text, $cx, 16); @@ -1805,7 +1815,6 @@ my %feature_keywords = ( # keywords that are strong and also have a prototype # my %strong_proto_keywords = map { $_ => 1 } qw( - glob pos prototype scalar @@ -2659,7 +2668,6 @@ sub listop { : $self->keyword($name) . '()' x (7 < $cx); } my $first; - $name = "socketpair" if $name eq "sockpair"; my $fullname = $self->keyword($name); my $proto = prototype("CORE::$name"); if ( @@ -2758,7 +2766,7 @@ sub pp_fcntl { listop(@_, "fcntl") } sub pp_ioctl { listop(@_, "ioctl") } sub pp_flock { maybe_targmy(@_, \&listop, "flock") } sub pp_socket { listop(@_, "socket") } -sub pp_sockpair { listop(@_, "sockpair") } +sub pp_sockpair { listop(@_, "socketpair") } sub pp_bind { listop(@_, "bind") } sub pp_connect { listop(@_, "connect") } sub pp_listen { listop(@_, "listen") } @@ -2804,13 +2812,19 @@ sub pp_syscall { listop(@_, "syscall") } sub pp_glob { my $self = shift; my($op, $cx) = @_; - my $text = $self->dq($op->first->sibling); # skip pushmark + my $kid = $op->first->sibling; # skip pushmark my $keyword = $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob'); - if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline - or $keyword =~ /^CORE::/ + my $text; + if ($keyword =~ /^CORE::/ + or $kid->name ne 'const' + or ($text = $self->dq($kid)) + =~ /^\$?(\w|::|\`)+$/ # could look like a readline or $text =~ /[<>]/) { - return "$keyword(" . single_delim('qq', '"', $text) . ')'; + $text = $self->deparse($kid); + return $cx >= 5 || $self->{'parens'} + ? "$keyword($text)" + : "$keyword $text"; } else { return '<' . $text . '>'; } @@ -2954,14 +2968,14 @@ sub pp_list { # OPs that store things other than flags in their op_private, # like OP_AELEMFAST, won't be immediate children of a list. # - # OP_ENTERSUB can break this logic, so check for it. + # OP_ENTERSUB and OP_SPLIT can break this logic, so check for them. # I suspect that open and exit can too. + # XXX This really needs to be rewritten to accept only those ops + # known to take the OPpLVAL_INTRO flag. if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO) or $lop->name eq "undef") - or $lop->name eq "entersub" - or $lop->name eq "exit" - or $lop->name eq "open") + or $lop->name =~ /^(?:entersub|exit|open|split)\z/) { $local = ""; # or not last; @@ -3111,7 +3125,7 @@ sub loop_common { # thread special var, under 5005threads $var = $self->pp_threadsv($enter, 1); } else { # regular my() variable - $var = $self->pp_padsv($enter, 1); + $var = $self->pp_padsv($enter, 1, 1); } } elsif ($var->name eq "rv2gv") { $var = $self->pp_rv2sv($var, 1); @@ -3198,9 +3212,12 @@ sub pp_leavetry { return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}"; } -BEGIN { for (qw[ const stringify rv2sv list glob ]) { - eval "sub OP_\U$_ () { " . opnumber($_) . "}" -}} +sub _op_is_or_was { + my ($op, $expect_type) = @_; + my $type = $op->type; + return($type == $expect_type + || ($type == OP_NULL && $op->targ == $expect_type)); +} sub pp_null { my $self = shift; @@ -3208,7 +3225,10 @@ sub pp_null { if (class($op) eq "OP") { # old value is lost return $self->{'ex_const'} if $op->targ == OP_CONST; - } elsif ($op->first->name eq "pushmark") { + } elsif ($op->first->name eq 'pushmark' + or $op->first->name eq 'null' + && $op->first->targ == OP_PUSHMARK + && _op_is_or_was($op, OP_LIST)) { return $self->pp_list($op, $cx); } elsif ($op->first->name eq "enter") { return $self->pp_leave($op, $cx); @@ -3267,8 +3287,9 @@ sub padany { sub pp_padsv { my $self = shift; - my($op, $cx) = @_; - return $self->maybe_my($op, $cx, $self->padname($op->targ)); + my($op, $cx, $forbid_parens) = @_; + return $self->maybe_my($op, $cx, $self->padname($op->targ), + $forbid_parens); } sub pp_padav { pp_padsv(@_) } @@ -3311,7 +3332,9 @@ sub pp_aelemfast_lex { my($op, $cx) = @_; my $name = $self->padname($op->targ); $name =~ s/^@/\$/; - return $name . "[" . ($op->private + $self->{'arybase'}) . "]"; + my $i = $op->private; + $i -= 256 if $i > 127; + return $name . "[" . ($i + $self->{'arybase'}) . "]"; } sub pp_aelemfast { @@ -3323,7 +3346,9 @@ sub pp_aelemfast { my $gv = $self->gv_or_padgv($op); my($name,$quoted) = $self->stash_variable_name('@',$gv); $name = $quoted ? "$name->" : '$' . $name; - return $name . "[" . ($op->private + $self->{'arybase'}) . "]"; + my $i = $op->private; + $i -= 256 if $i > 127; + return $name . "[" . ($i + $self->{'arybase'}) . "]"; } sub rv2x { @@ -3377,7 +3402,7 @@ sub pp_av2arylen { sub pp_rv2cv { my ($self, $op, $cx) = @_; if (!null($op->first) && $op->first->name eq 'null' && - $op->first->targ eq OP_LIST) + $op->first->targ == OP_LIST) { return $self->rv2x($op->first->first->sibling, $cx, "&") } @@ -3511,7 +3536,9 @@ sub elem { } if (my $array_name=$self->elem_or_slice_array_name ($array, $left, $padname, 1)) { - return ($array_name =~ /->\z/ ? $array_name : "\$" . $array_name) + return ($array_name =~ /->\z/ + ? $array_name + : $array_name eq '#' ? '${#}' : "\$" . $array_name) . $left . $idx . $right; } else { # $x[20][3]{hi} or expr->[20] @@ -3561,11 +3588,15 @@ sub slice { } else { $list = $self->elem_or_slice_single_index($kid); } - return "\@" . $array . $left . $list . $right; + my $lead = '@'; + $lead = '%' if $op->name =~ /^kv/i; + return $lead . $array . $left . $list . $right; } -sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) } -sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) } +sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) } +sub pp_kvaslice { slice(@_, "[", "]", "rv2av", "padav") } +sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) } +sub pp_kvhslice { slice(@_, "{", "}", "rv2hv", "padhv") } sub pp_lslice { my $self = shift; @@ -3681,8 +3712,9 @@ sub check_proto { my @reals; # An unbackslashed @ or % gobbles up the rest of the args 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/; + $proto =~ s/^\s*//; while ($proto) { - $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)//; + $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)\s*//; my $chr = $1; if ($chr eq "") { return "&" if @args; @@ -3839,7 +3871,7 @@ sub pp_entersub { my $dproto = defined($proto) ? $proto : "undefined"; if (!$declared) { return "$kid(" . $args . ")"; - } elsif ($dproto eq "") { + } elsif ($dproto =~ /^\s*\z/) { return $kid; } elsif ($dproto eq "\$" and is_scalar($exprs[0])) { # is_scalar is an excessively conservative test here: @@ -3934,7 +3966,7 @@ sub re_uninterp_extended { } } -my %unctrl = # portable to to EBCDIC +my %unctrl = # portable to EBCDIC ( "\c@" => '\c@', # unused "\cA" => '\cA', @@ -4188,7 +4220,11 @@ sub const { } } - return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20); + my $const = $self->const($ref, 20); + if ($self->{in_subst_repl} && $const =~ /^[0-9]/) { + $const = "($const)"; + } + return $self->maybe_parens("\\$const", $cx, 20); } elsif ($sv->FLAGS & SVf_POK) { my $str = $sv->PV; if ($str =~ /[[:^print:]]/) { @@ -4612,7 +4648,7 @@ sub pure_string { } elsif ($type eq 'join') { my $join_op = $op->first->sibling; # Skip pushmark - return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV; + return 0 unless $join_op->name eq 'null' && $join_op->targ == OP_RV2SV; my $gvop = $join_op->first; return 0 unless $gvop->name eq 'gvsv'; @@ -4859,10 +4895,13 @@ sub pp_subst { $repl = $repl->first; $flags .= "e"; } - if ($pmflags & PMf_EVAL) { + { + local $self->{in_subst_repl} = 1; + if ($pmflags & PMf_EVAL) { $repl = $self->deparse($repl->first, 0); - } else { + } else { $repl = $self->dq($repl); + } } my $extended = ($pmflags & PMf_EXTENDED); if (null $kid) { @@ -5297,7 +5336,7 @@ parameter twice: warnings => [FATAL => qw/void io/], ); -See L<perllexwarn> for more information about lexical warnings. +See L<warnings> for more information about lexical warnings. =item hint_bits diff --git a/Master/tlpkg/tlperl/lib/B/Lint.pm b/Master/tlpkg/tlperl/lib/B/Lint.pm deleted file mode 100644 index fd8d75e53ac..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Lint.pm +++ /dev/null @@ -1,793 +0,0 @@ -package B::Lint; -use if $] > 5.017, 'deprecate'; - -our $VERSION = '1.17'; ## no critic - -=head1 NAME - -B::Lint - Perl lint - -=head1 SYNOPSIS - -perl -MO=Lint[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -The B::Lint module is equivalent to an extended version of the B<-w> -option of B<perl>. It is named after the program F<lint> which carries -out a similar process for C programs. - -=head1 OPTIONS AND LINT CHECKS - -Option words are separated by commas (not whitespace) and follow the -usual conventions of compiler backend options. Following any options -(indicated by a leading B<->) come lint check arguments. Each such -argument (apart from the special B<all> and B<none> options) is a -word representing one possible lint check (turning on that check) or -is B<no-foo> (turning off that check). Before processing the check -arguments, a standard list of checks is turned on. Later options -override earlier ones. Available options are: - -=over 8 - -=item B<magic-diamond> - -Produces a warning whenever the magic C<E<lt>E<gt>> readline is -used. Internally it uses perl's two-argument open which itself treats -filenames with special characters specially. This could allow -interestingly named files to have unexpected effects when reading. - - % touch 'rm *|' - % perl -pe 1 - -The above creates a file named C<rm *|>. When perl opens it with -C<E<lt>E<gt>> it actually executes the shell program C<rm *>. This -makes C<E<lt>E<gt>> dangerous to use carelessly. - -=item B<context> - -Produces a warning whenever an array is used in an implicit scalar -context. For example, both of the lines - - $foo = length(@bar); - $foo = @bar; - -will elicit a warning. Using an explicit B<scalar()> silences the -warning. For example, - - $foo = scalar(@bar); - -=item B<implicit-read> and B<implicit-write> - -These options produce a warning whenever an operation implicitly -reads or (respectively) writes to one of Perl's special variables. -For example, B<implicit-read> will warn about these: - - /foo/; - -and B<implicit-write> will warn about these: - - s/foo/bar/; - -Both B<implicit-read> and B<implicit-write> warn about this: - - for (@a) { ... } - -=item B<bare-subs> - -This option warns whenever a bareword is implicitly quoted, but is also -the name of a subroutine in the current package. Typical mistakes that it will -trap are: - - use constant foo => 'bar'; - @a = ( foo => 1 ); - $b{foo} = 2; - -Neither of these will do what a naive user would expect. - -=item B<dollar-underscore> - -This option warns whenever C<$_> is used either explicitly anywhere or -as the implicit argument of a B<print> statement. - -=item B<private-names> - -This option warns on each use of any variable, subroutine or -method name that lives in a non-current package but begins with -an underscore ("_"). Warnings aren't issued for the special case -of the single character name "_" by itself (e.g. C<$_> and C<@_>). - -=item B<undefined-subs> - -This option warns whenever an undefined subroutine is invoked. -This option will only catch explicitly invoked subroutines such -as C<foo()> and not indirect invocations such as C<&$subref()> -or C<$obj-E<gt>meth()>. Note that some programs or modules delay -definition of subs until runtime by means of the AUTOLOAD -mechanism. - -=item B<regexp-variables> - -This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'> -is used. Any occurrence of any of these variables in your -program can slow your whole program down. See L<perlre> for -details. - -=item B<all> - -Turn all warnings on. - -=item B<none> - -Turn all warnings off. - -=back - -=head1 NON LINT-CHECK OPTIONS - -=over 8 - -=item B<-u Package> - -Normally, Lint only checks the main code of the program together -with all subs defined in package main. The B<-u> option lets you -include other package names whose subs are then checked by Lint. - -=back - -=head1 EXTENDING LINT - -Lint can be extended by with plugins. Lint uses L<Module::Pluggable> -to find available plugins. Plugins are expected but not required to -inform Lint of which checks they are adding. - -The C<< B::Lint->register_plugin( MyPlugin => \@new_checks ) >> method -adds the list of C<@new_checks> to the list of valid checks. If your -module wasn't loaded by L<Module::Pluggable> then your class name is -added to the list of plugins. - -You must create a C<match( \%checks )> method in your plugin class or one -of its parents. It will be called on every op as a regular method call -with a hash ref of checks as its parameter. - -The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain -the current filename and line number. - - package Sample; - use B::Lint; - B::Lint->register_plugin( Sample => [ 'good_taste' ] ); - - sub match { - my ( $op, $checks_href ) = shift @_; - if ( $checks_href->{good_taste} ) { - ... - } - } - -=head1 TODO - -=over - -=item while(<FH>) stomps $_ - -=item strict oo - -=item unchecked system calls - -=item more tests, validate against older perls - -=back - -=head1 BUGS - -This is only a very preliminary version. - -=head1 AUTHOR - -Malcolm Beattie, mbeattie@sable.ox.ac.uk. - -=head1 ACKNOWLEDGEMENTS - -Sebastien Aperghis-Tramoni - bug fixes - -=cut - -use strict; -use B qw( walkoptree_slow - main_root main_cv walksymtable parents - OPpOUR_INTRO - OPf_WANT_VOID OPf_WANT_LIST OPf_WANT OPf_STACKED SVf_POK ); -use Carp 'carp'; - -# The current M::P doesn't know about .pmc files. -use Module::Pluggable ( require => 1 ); - -use List::Util 'first'; -## no critic Prototypes -sub any (&@) { my $test = shift @_; $test->() and return 1 for @_; return 0 } - -BEGIN { - - # Import or create some constants from B. B doesn't provide - # everything I need so some things like OPpCONST_BARE are defined - # here. - for my $sym ( qw( begin_av check_av init_av end_av ), - [ 'OPpCONST_BARE' => 64 ] ) - { - my $val; - ( $sym, $val ) = @$sym if ref $sym; - - if ( any { $sym eq $_ } @B::EXPORT_OK, @B::EXPORT ) { - B->import($sym); - } - else { - require constant; - constant->import( $sym => $val ); - } - } -} - -my $file = "unknown"; # shadows current filename -my $line = 0; # shadows current line number -my $curstash = "main"; # shadows current stash -my $curcv; # shadows current B::CV for pad lookups - -sub file {$file} -sub line {$line} -sub curstash {$curstash} -sub curcv {$curcv} - -# Lint checks -my %check; -my %implies_ok_context; - -map( $implies_ok_context{$_}++, - qw(scalar av2arylen aelem aslice helem hslice - keys values hslice defined undef delete) ); - -# Lint checks turned on by default -my @default_checks - = qw(context magic_diamond undefined_subs regexp_variables); - -my %valid_check; - -# All valid checks -for my $check ( - qw(context implicit_read implicit_write dollar_underscore - private_names bare_subs undefined_subs regexp_variables - magic_diamond ) - ) -{ - $valid_check{$check} = __PACKAGE__; -} - -# Debugging options -my ($debug_op); - -my %done_cv; # used to mark which subs have already been linted -my @extra_packages; # Lint checks mainline code and all subs which are - # in main:: or in one of these packages. - -sub warning { - my $format = ( @_ < 2 ) ? "%s" : shift @_; - warn sprintf( "$format at %s line %d\n", @_, $file, $line ); - return undef; ## no critic undef -} - -# This gimme can't cope with context that's only determined -# at runtime via dowantarray(). -sub gimme { - my $op = shift @_; - my $flags = $op->flags; - if ( $flags & OPf_WANT ) { - return ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ? 1 : 0 ); - } - return undef; ## no critic undef -} - -my @plugins = __PACKAGE__->plugins; - -sub inside_grepmap { - - # A boolean function to be used while inside a B::walkoptree_slow - # call. If we are in the EXPR part of C<grep EXPR, ...> or C<grep - # { EXPR } ...>, this returns true. - return any { $_->name =~ m/\A(?:grep|map)/xms } @{ parents() }; -} - -sub inside_foreach_modifier { - - # TODO: use any() - - # A boolean function to be used while inside a B::walkoptree_slow - # call. If we are in the EXPR part of C<EXPR foreach ...> this - # returns true. - for my $ancestor ( @{ parents() } ) { - next unless $ancestor->name eq 'leaveloop'; - - my $first = $ancestor->first; - next unless $first->name eq 'enteriter'; - - next if $first->redoop->name =~ m/\A(?:next|db|set)state\z/xms; - - return 1; - } - return 0; -} - -for ( - [qw[ B::PADOP::gv_harder gv padix]], - [qw[ B::SVOP::sv_harder sv targ]], - [qw[ B::SVOP::gv_harder gv padix]] - ) -{ - - # I'm generating some functions here because they're mostly - # similar. It's all for compatibility with threaded - # perl. Perhaps... this code should inspect $Config{usethreads} - # and generate a *specific* function. I'm leaving it generic for - # the moment. - # - # In threaded perl SVs and GVs aren't used directly in the optrees - # like they are in non-threaded perls. The ops that would use a SV - # or GV keep an index into the subroutine's scratchpad. I'm - # currently ignoring $cv->DEPTH and that might be at my peril. - - my ( $subname, $attr, $pad_attr ) = @$_; - my $target = do { ## no critic strict - no strict 'refs'; - \*$subname; - }; - *$target = sub { - my ($op) = @_; - - my $elt; - if ( not $op->isa('B::PADOP') ) { - $elt = $op->$attr; - } - return $elt if eval { $elt->isa('B::SV') }; - - my $ix = $op->$pad_attr; - my @entire_pad = $curcv->PADLIST->ARRAY; - my @elts = map +( $_->ARRAY )[$ix], @entire_pad; - ($elt) = first { - eval { $_->isa('B::SV') } ? $_ : (); - } - @elts[ 0, reverse 1 .. $#elts ]; - return $elt; - }; -} - -sub B::OP::lint { - my ($op) = @_; - - # This is a fallback ->lint for all the ops where I haven't - # defined something more specific. Nothing happens here. - - # Call all registered plugins - my $m; - $m = $_->can('match'), $op->$m( \%check ) for @plugins; - return; -} - -sub B::COP::lint { - my ($op) = @_; - - # nextstate ops sit between statements. Whenever I see one I - # update the current info on file, line, and stash. This code also - # updates it when it sees a dbstate or setstate op. I have no idea - # what those are but having seen them mentioned together in other - # parts of the perl I think they're kind of equivalent. - if ( $op->name =~ m/\A(?:next|db|set)state\z/ ) { - $file = $op->file; - $line = $op->line; - $curstash = $op->stash->NAME; - } - - # Call all registered plugins - my $m; - $m = $_->can('match'), $op->$m( \%check ) for @plugins; - return; -} - -sub B::UNOP::lint { - my ($op) = @_; - - my $opname = $op->name; - -CONTEXT: { - - # Check arrays and hashes in scalar or void context where - # scalar() hasn't been used. - - next - unless $check{context} - and $opname =~ m/\Arv2[ah]v\z/xms - and not gimme($op); - - my ( $parent, $gparent ) = @{ parents() }[ 0, 1 ]; - my $pname = $parent->name; - - next if $implies_ok_context{$pname}; - - # Three special cases to deal with: "foreach (@foo)", "delete - # $a{$b}", and "exists $a{$b}" null out the parent so we have to - # check for a parent of pp_null and a grandparent of - # pp_enteriter, pp_delete, pp_exists - - next - if $pname eq "null" - and $gparent->name =~ m/\A(?:delete|enteriter|exists)\z/xms; - - # our( @bar ); would also trigger this error so I exclude - # that. - next - if $op->private & OPpOUR_INTRO - and ( $op->flags & OPf_WANT ) == OPf_WANT_VOID; - - warning 'Implicit scalar context for %s in %s', - $opname eq "rv2av" ? "array" : "hash", $parent->desc; - } - -PRIVATE_NAMES: { - - # Looks for calls to methods with names that begin with _ and - # that aren't visible within the current package. Maybe this - # should look at @ISA. - next - unless $check{private_names} - and $opname =~ m/\Amethod/xms; - - my $methop = $op->first; - next unless $methop->name eq "const"; - - my $method = $methop->sv_harder->PV; - next - unless $method =~ m/\A_/xms - and not defined &{"$curstash\::$method"}; - - warning q[Illegal reference to private method name '%s'], $method; - } - - # Call all registered plugins - my $m; - $m = $_->can('match'), $op->$m( \%check ) for @plugins; - return; -} - -sub B::PMOP::lint { - my ($op) = @_; - -IMPLICIT_READ: { - - # Look for /.../ that doesn't use =~ to bind to something. - next - unless $check{implicit_read} - and $op->name eq "match" - and not( $op->flags & OPf_STACKED - or inside_grepmap() ); - warning 'Implicit match on $_'; - } - -IMPLICIT_WRITE: { - - # Look for s/.../.../ that doesn't use =~ to bind to - # something. - next - unless $check{implicit_write} - and $op->name eq "subst" - and not $op->flags & OPf_STACKED; - warning 'Implicit substitution on $_'; - } - - # Call all registered plugins - my $m; - $m = $_->can('match'), $op->$m( \%check ) for @plugins; - return; -} - -sub B::LOOP::lint { - my ($op) = @_; - -IMPLICIT_FOO: { - - # Look for C<for ( ... )>. - next - unless ( $check{implicit_read} or $check{implicit_write} ) - and $op->name eq "enteriter"; - - my $last = $op->last; - next - unless $last->name eq "gv" - and $last->gv_harder->NAME eq "_" - and $op->redoop->name =~ m/\A(?:next|db|set)state\z/xms; - - warning 'Implicit use of $_ in foreach'; - } - - # Call all registered plugins - my $m; - $m = $_->can('match'), $op->$m( \%check ) for @plugins; - return; -} - -# In threaded vs non-threaded perls you'll find that threaded perls -# use PADOP in place of SVOPs so they can do lookups into the -# scratchpad to find things. I suppose this is so a optree can be -# shared between threads and all symbol table muckery will just get -# written to a scratchpad. -*B::PADOP::lint = *B::PADOP::lint = \&B::SVOP::lint; - -sub B::SVOP::lint { - my ($op) = @_; - -MAGIC_DIAMOND: { - next - unless $check{magic_diamond} - and parents()->[0]->name eq 'readline' - and $op->gv_harder->NAME eq 'ARGV'; - - warning 'Use of <>'; - } - -BARE_SUBS: { - next - unless $check{bare_subs} - and $op->name eq 'const' - and $op->private & OPpCONST_BARE; - - my $sv = $op->sv_harder; - next unless $sv->FLAGS & SVf_POK; - - my $sub = $sv->PV; - my $subname = "$curstash\::$sub"; - - # I want to skip over things that were declared with the - # constant pragma. Well... sometimes. Hmm. I want to ignore - # C<<use constant FOO => ...>> but warn on C<<FOO => ...>> - # later. The former is typical declaration syntax and the - # latter would be an error. - # - # Skipping over both could be handled by looking if - # $constant::declared{$subname} is true. - - # Check that it's a function. - next - unless exists &{"$curstash\::$sub"}; - - warning q[Bare sub name '%s' interpreted as string], $sub; - } - -PRIVATE_NAMES: { - next unless $check{private_names}; - - my $opname = $op->name; - if ( $opname =~ m/\Agv(?:sv)?\z/xms ) { - - # Looks for uses of variables and stuff that are named - # private and we're not in the same package. - my $gv = $op->gv_harder; - my $name = $gv->NAME; - next - unless $name =~ m/\A_./xms - and $gv->STASH->NAME ne $curstash; - - warning q[Illegal reference to private name '%s'], $name; - } - elsif ( $opname eq "method_named" ) { - my $method = $op->sv_harder->PV; - next unless $method =~ m/\A_./xms; - - warning q[Illegal reference to private method name '%s'], $method; - } - } - -DOLLAR_UNDERSCORE: { - - # Warn on uses of $_ with a few exceptions. I'm not warning on - # $_ inside grep, map, or statement modifier foreach because - # they localize $_ and it'd be impossible to use these - # features without getting warnings. - - next - unless $check{dollar_underscore} - and $op->name eq "gvsv" - and $op->gv_harder->NAME eq "_" - and not( inside_grepmap - or inside_foreach_modifier ); - - warning 'Use of $_'; - } - -REGEXP_VARIABLES: { - - # Look for any uses of $`, $&, or $'. - next - unless $check{regexp_variables} - and $op->name eq "gvsv"; - - my $name = $op->gv_harder->NAME; - next unless $name =~ m/\A[\&\'\`]\z/xms; - - warning 'Use of regexp variable $%s', $name; - } - -UNDEFINED_SUBS: { - - # Look for calls to functions that either don't exist or don't - # have a definition. - next - unless $check{undefined_subs} - and $op->name eq "gv" - and $op->next->name eq "entersub"; - - my $gv = $op->gv_harder; - my $subname = $gv->STASH->NAME . "::" . $gv->NAME; - - no strict 'refs'; ## no critic strict - if ( not exists &$subname ) { - $subname =~ s/\Amain:://; - warning q[Nonexistent subroutine '%s' called], $subname; - } - elsif ( not defined &$subname ) { - $subname =~ s/\A\&?main:://; - warning q[Undefined subroutine '%s' called], $subname; - } - } - - # Call all registered plugins - my $m; - $m = $_->can('match'), $op->$m( \%check ) for @plugins; - return; -} - -sub B::GV::lintcv { - - # Example: B::svref_2object( \ *A::Glob )->lintcv - - my $gv = shift @_; - my $cv = $gv->CV; - return unless $cv->can('lintcv'); - $cv->lintcv; - return; -} - -sub B::CV::lintcv { - - # Example: B::svref_2object( \ &foo )->lintcv - - # Write to the *global* $ - $curcv = shift @_; - - #warn sprintf("lintcv: %s::%s (done=%d)\n", - # $gv->STASH->NAME, $gv->NAME, $done_cv{$$curcv});#debug - return unless ref($curcv) and $$curcv and not $done_cv{$$curcv}++; - my $root = $curcv->ROOT; - - #warn " root = $root (0x$$root)\n";#debug - walkoptree_slow( $root, "lint" ) if $$root; - return; -} - -sub do_lint { - my %search_pack; - - # Copy to the global $curcv for use in pad lookups. - $curcv = main_cv; - walkoptree_slow( main_root, "lint" ) if ${ main_root() }; - - # Do all the miscellaneous non-sub blocks. - for my $av ( begin_av, init_av, check_av, end_av ) { - next unless eval { $av->isa('B::AV') }; - for my $cv ( $av->ARRAY ) { - next unless ref($cv) and $cv->FILE eq $0; - $cv->lintcv; - } - } - - walksymtable( - \%main::, - sub { - if ( $_[0]->FILE eq $0 ) { $_[0]->lintcv } - }, - sub {1} - ); - return; -} - -sub compile { - my @options = @_; - - # Turn on default lint checks - for my $opt (@default_checks) { - $check{$opt} = 1; - } - -OPTION: - while ( my $option = shift @options ) { - my ( $opt, $arg ); - unless ( ( $opt, $arg ) = $option =~ m/\A-(.)(.*)/xms ) { - unshift @options, $option; - last OPTION; - } - - if ( $opt eq "-" && $arg eq "-" ) { - shift @options; - last OPTION; - } - elsif ( $opt eq "D" ) { - $arg ||= shift @options; - foreach my $arg ( split //, $arg ) { - if ( $arg eq "o" ) { - B->debug(1); - } - elsif ( $arg eq "O" ) { - $debug_op = 1; - } - } - } - elsif ( $opt eq "u" ) { - $arg ||= shift @options; - push @extra_packages, $arg; - } - } - - foreach my $opt ( @default_checks, @options ) { - $opt =~ tr/-/_/; - if ( $opt eq "all" ) { - %check = %valid_check; - } - elsif ( $opt eq "none" ) { - %check = (); - } - else { - if ( $opt =~ s/\Ano_//xms ) { - $check{$opt} = 0; - } - else { - $check{$opt} = 1; - } - carp "No such check: $opt" - unless defined $valid_check{$opt}; - } - } - - # Remaining arguments are things to check. So why aren't I - # capturing them or something? I don't know. - - return \&do_lint; -} - -sub register_plugin { - my ( undef, $plugin, $new_checks ) = @_; - - # Allow the user to be lazy and not give us a name. - $plugin = caller unless defined $plugin; - - # Register the plugin's named checks, if any. - for my $check ( eval {@$new_checks} ) { - if ( not defined $check ) { - carp 'Undefined value in checks.'; - next; - } - if ( exists $valid_check{$check} ) { - carp - "$check is already registered as a $valid_check{$check} feature."; - next; - } - - $valid_check{$check} = $plugin; - } - - # Register a non-Module::Pluggable loaded module. @plugins already - # contains whatever M::P found on disk. The user might load a - # plugin manually from some arbitrary namespace and ask for it to - # be registered. - if ( not any { $_ eq $plugin } @plugins ) { - push @plugins, $plugin; - } - - return; -} - -1; diff --git a/Master/tlpkg/tlperl/lib/B/Lint/Debug.pm b/Master/tlpkg/tlperl/lib/B/Lint/Debug.pm deleted file mode 100644 index 7dea1b57b24..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Lint/Debug.pm +++ /dev/null @@ -1,73 +0,0 @@ -package B::Lint::Debug; -use if $] > 5.017, 'deprecate'; - -our $VERSION = '1.17'; - -=head1 NAME - -B::Lint::Debug - Adds debugging stringification to B:: - -=head1 DESCRIPTION - -This module injects stringification to a B::OP*/B::SPECIAL. This -should not be loaded unless you're debugging. - -=cut - -package # hide from PAUSE - B::SPECIAL; -use overload '""' => sub { - my $self = shift @_; - "SPECIAL($$self)"; -}; - -package # hide from PAUSE - B::OP; -use overload '""' => sub { - my $self = shift @_; - my $class = ref $self; - $class =~ s/\AB:://xms; - my $name = $self->name; - "$class($name)"; -}; - -package # hide from PAUSE - B::SVOP; -use overload '""' => sub { - my $self = shift @_; - my $class = ref $self; - $class =~ s/\AB:://xms; - my $name = $self->name; - "$class($name," . $self->sv . "," . $self->gv . ")"; -}; - -package # hide from PAUSE - B::SPECIAL; -sub DESTROY { } -our $AUTOLOAD; - -sub AUTOLOAD { - my $cx = 0; - print "AUTOLOAD $AUTOLOAD\n"; - - package # hide from PAUSE - DB; - while ( my @stuff = caller $cx ) { - - print "$cx: [@DB::args] [@stuff]\n"; - if ( ref $DB::args[0] ) { - if ( $DB::args[0]->can('padix') ) { - print " PADIX: " . $DB::args[0]->padix . "\n"; - } - if ( $DB::args[0]->can('targ') ) { - print " TARG: " . $DB::args[0]->targ . "\n"; - for ( B::Lint::cv()->PADLIST->ARRAY ) { - print +( $_->ARRAY )[ $DB::args[0]->targ ] . "\n"; - } - } - } - ++$cx; - } -} - -1; diff --git a/Master/tlpkg/tlperl/lib/B/Showlex.pm b/Master/tlpkg/tlperl/lib/B/Showlex.pm index 2de8aa49b28..ab684516100 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.03'; +our $VERSION = '1.04'; use strict; use B qw(svref_2object comppadlist class); @@ -196,7 +196,7 @@ example. See L<B::Concise> for a fuller explanation of reasons. Some of the reported info, such as hex addresses, is not particularly valuable. Other information would be more useful for the typical programmer, such as line-numbers, pad-slot reuses, etc.. Given this, --newlex isnt a particularly good flag-name. +-newlex is not a particularly good flag-name. =head1 AUTHOR |