X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2FB%2FDeparse.pm;h=37b98a034386607fafb1d11b2f227ce7163a40f1;hb=c27ea44e678f02a1903a4aa0e3110ba824fcd93a;hp=fd8819167c944e1fca13255bd4fe2efaab2e9aab;hpb=083bda0273e218fe3e0e3d7d62103426dba06c88;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm index fd88191..37b98a0 100644 --- a/ext/B/B/Deparse.pm +++ b/ext/B/B/Deparse.pm @@ -7,20 +7,21 @@ # but essentially none of his code remains. package B::Deparse; -use Carp 'cluck', 'croak'; -use B qw(class main_root main_start main_cv svref_2object opnumber cstring +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 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 - SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR + SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE CVf_METHOD CVf_LOCKED CVf_LVALUE PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = 0.62; +$VERSION = 0.63; use strict; +use vars qw/$AUTOLOAD/; use warnings (); # Changes between 0.50 and 0.51: @@ -105,6 +106,10 @@ use warnings (); # - our() declarations # - *all* the known bugs are now listed in the BUGS section # - comprehensive test mechanism (TEST -deparse) +# Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez) +# - bug-fixes +# - new switch -P +# - support for command-line switches (-l, -0, etc.) # Todo: # (See also BUGS section at the end of this file) @@ -169,6 +174,9 @@ use warnings (); # keys are names of subs for which we've printed declarations. # That means we can omit parentheses from the arguments. # +# subs_deparsed +# Keeps track of fully qualified names of all deparsed subs. +# # parens: -p # linenums: -l # unquote: -q @@ -252,6 +260,9 @@ sub todo { $seq = 0; } push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form]; + unless ($is_form || class($cv->STASH) eq 'SPECIAL') { + $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1; + } } sub next_todo { @@ -483,6 +494,8 @@ sub new { $self->{'files'}{$1} = 1; } elsif ($arg eq "-p") { $self->{'parens'} = 1; + } elsif ($arg eq "-P") { + $self->{'noproto'} = 1; } elsif ($arg eq "-l") { $self->{'linenums'} = 1; } elsif ($arg eq "-q") { @@ -529,20 +542,21 @@ sub compile { my $self = B::Deparse->new(@args); # First deparse command-line args if (defined $^I) { # deparse -i - print q(BEGIN { $^I = ).cstring($^I).qq(; }\n); + print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n); } if ($^W) { # deparse -w print qq(BEGIN { \$^W = $^W; }\n); } if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0 - my $fs = cstring($/) || 'undef'; - my $bs = cstring($O::savebackslash) || 'undef'; + my $fs = perlstring($/) || 'undef'; + my $bs = perlstring($O::savebackslash) || 'undef'; print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n); } my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : (); + my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : (); my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : (); my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : (); - for my $block (@BEGINs, @INITs, @ENDs) { + for my $block (@BEGINs, @CHECKs, @INITs, @ENDs) { $self->todo($block, 0); } $self->stash_subs(); @@ -561,9 +575,11 @@ sub compile { # Print __DATA__ section, if necessary no strict 'refs'; - if (defined *{$self->{'curstash'}."::DATA"}{IO}) { + my $laststash = defined $self->{'curcop'} + ? $self->{'curcop'}->stash->NAME : $self->{'curstash'}; + if (defined *{$laststash."::DATA"}{IO}) { print "__DATA__\n"; - print readline(*{$self->{'curstash'}."::DATA"}); + print readline(*{$laststash."::DATA"}); } } } @@ -571,7 +587,7 @@ sub compile { sub coderef2text { my $self = shift; my $sub = shift; - croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE"; + croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE"); $self->init(); return $self->indent($self->deparse_sub(svref_2object($sub))); @@ -785,7 +801,8 @@ sub deparse_format { = @$self{qw'curstash warnings hints'}; my $op = $form->ROOT; my $kid; - return "\f." if $op->first->name eq 'stub'; + return "\f." if $op->first->name eq 'stub' + || $op->first->name eq 'nextstate'; $op = $op->first->first; # skip leavewrite, lineseq while (not null $op) { $op = $op->sibling; # skip nextstate @@ -943,90 +960,16 @@ sub maybe_my { # pp_padany -- does not exist after parsing -sub pp_enter { # see also leave - cluck "unexpected OP_ENTER"; - return "XXX"; -} - -sub pp_pushmark { # see also list - cluck "unexpected OP_PUSHMARK"; - return "XXX"; -} - -sub pp_leavesub { # see also deparse_sub - cluck "unexpected OP_LEAVESUB"; - return "XXX"; -} - -sub pp_leavewrite { # see also deparse_format - cluck "unexpected OP_LEAVEWRITE"; - return "XXX"; -} - -sub pp_method { # see also entersub - cluck "unexpected OP_METHOD"; - return "XXX"; -} - -sub pp_regcmaybe { # see also regcomp - cluck "unexpected OP_REGCMAYBE"; - return "XXX"; -} - -sub pp_regcreset { # see also regcomp - cluck "unexpected OP_REGCRESET"; - return "XXX"; -} - -sub pp_substcont { # see also subst - cluck "unexpected OP_SUBSTCONT"; - return "XXX"; -} - -sub pp_grepstart { # see also grepwhile - cluck "unexpected OP_GREPSTART"; - return "XXX"; -} - -sub pp_mapstart { # see also mapwhile - cluck "unexpected OP_MAPSTART"; - return "XXX"; -} - -sub pp_method_named { - cluck "unexpected OP_METHOD_NAMED"; - return "XXX"; -} - -sub pp_flip { # see also flop - cluck "unexpected OP_FLIP"; - return "XXX"; -} - -sub pp_iter { # see also leaveloop - cluck "unexpected OP_ITER"; - return "XXX"; -} - -sub pp_enteriter { # see also leaveloop - cluck "unexpected OP_ENTERITER"; - return "XXX"; -} - -sub pp_enterloop { # see also leaveloop - cluck "unexpected OP_ENTERLOOP"; - return "XXX"; -} - -sub pp_leaveeval { # see also entereval - cluck "unexpected OP_LEAVEEVAL"; - return "XXX"; +sub AUTOLOAD { + if ($AUTOLOAD =~ s/^.*::pp_//) { + warn "unexpected OP_".uc $AUTOLOAD; + return "XXX"; + } else { + die "Undefined subroutine $AUTOLOAD called"; + } } -sub pp_entertry { # see also leavetry - cluck "unexpected OP_ENTERTRY"; - return "XXX"; -} +sub DESTROY {} # Do not AUTOLOAD # $root should be the op which represents the root of whatever # we're sequencing here. If it's undefined, then we don't append @@ -1138,7 +1081,8 @@ sub gv_name { Carp::confess() if $gv->isa("B::CV"); my $stash = $gv->STASH->NAME; my $name = $gv->SAFENAME; - if ($stash eq $self->{'curstash'} or $globalnames{$name} + if (($stash eq 'main' && $globalnames{$name}) + or ($stash eq $self->{'curstash'} && !$globalnames{$name}) or $name =~ /^[^A-Za-z_]/) { $stash = ""; @@ -1186,7 +1130,10 @@ sub lex_in_scope { sub populate_curcvlex { my $self = shift; for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) { - my @padlist = $cv->PADLIST->ARRAY; + my $padlist = $cv->PADLIST; + # an undef CV still in lexical chain + next if class($padlist) eq "SPECIAL"; + my @padlist = $padlist->ARRAY; my @ns = $padlist[0]->ARRAY; for (my $i=0; $i<@ns; ++$i) { @@ -1197,8 +1144,10 @@ sub populate_curcvlex { next; } my $name = $ns[$i]->PVX; - my $seq_st = $ns[$i]->NVX; - my $seq_en = int($ns[$i]->IVX); + my ($seq_st, $seq_en) = + ($ns[$i]->FLAGS & SVf_FAKE) + ? (0, 999999) + : ($ns[$i]->NVX, $ns[$i]->IVX); push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en]; } @@ -1211,7 +1160,7 @@ sub find_scope_en { ((find_scope(@_))[1]); } # Recurses down the tree, looking for pad variable introductions and COPs sub find_scope { my ($self, $op, $scope_st, $scope_en) = @_; -Carp::cluck() if !defined $op; + carp("Undefined op in find_scope") if !defined $op; return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS; for (my $o=$op->first; $$o; $o=$o->sibling) { @@ -1323,7 +1272,7 @@ sub declare_warnings { elsif (($to & WARN_MASK) eq "\0"x length($to)) { return "no warnings;\n"; } - return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n"; + return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n"; } sub declare_hints { @@ -1612,7 +1561,6 @@ sub pp_scalar { sub padval { my $self = shift; my $targ = shift; - #cluck "curcv was undef" unless $self->{curcv}; return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ]; } @@ -2009,6 +1957,7 @@ sub logop { sub pp_and { logop(@_, "and", 3, "&&", 11, "if") } sub pp_or { logop(@_, "or", 2, "||", 10, "unless") } +sub pp_dor { logop(@_, "err", 2, "//", 10, "") } # xor is syntactically a logop, but it's really a binop (contrary to # old versions of opcode.pl). Syntax is what matters here. @@ -2025,7 +1974,8 @@ sub logassignop { } sub pp_andassign { logassignop(@_, "&&=") } -sub pp_orassign { logassignop(@_, "||=") } +sub pp_orassign { logassignop(@_, "||=") } +sub pp_dorassign { logassignop(@_, "//=") } sub listop { my $self = shift; @@ -2035,6 +1985,7 @@ sub listop { my $kid = $op->first->sibling; return $name if null $kid; my $first; + $name = "socketpair" if $name eq "sockpair"; if (defined prototype("CORE::$name") && prototype("CORE::$name") =~ /^;?\*/ && $kid->name eq "rv2gv") { @@ -2233,7 +2184,7 @@ sub mapop { $kid = $kid->sibling; for (; !null($kid); $kid = $kid->sibling) { $expr = $self->deparse($kid, 6); - push @exprs, $expr if $expr; + push @exprs, $expr if defined $expr; } return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5); } @@ -2472,7 +2423,7 @@ BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" } sub pp_null { my $self = shift; - my($op, $cx) = @_; + my($op, $cx, $flags) = @_; if (class($op) eq "OP") { # old value is lost return $self->{'ex_const'} if $op->targ == OP_CONST; @@ -2495,7 +2446,12 @@ sub pp_null { . $self->deparse($op->first->sibling, 20), $cx, 20); } elsif ($op->flags & OPf_SPECIAL && $cx == 0 && !$op->targ) { - return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};"; + if ($flags) { + return $self->deparse($op->first, $cx); + } + else { + return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};"; + } } elsif (!null($op->first->sibling) and $op->first->sibling->name eq "null" and class($op->first->sibling) eq "UNOP" and @@ -2587,7 +2543,7 @@ sub rv2x { my($op, $cx, $type) = @_; if (class($op) eq 'NULL' || !$op->can("first")) { - Carp::cluck("Unexpected op in pp_rv2x"); + carp("Unexpected op in pp_rv2x"); return 'XXX'; } my $kid = $op->first; @@ -2847,14 +2803,15 @@ sub method { # or ("", $args_after_prototype_demunging) if it does. sub check_proto { my $self = shift; + return "&" if $self->{'noproto'}; my($proto, @args) = @_; my($arg, $real); my $doneok = 0; my @reals; # An unbackslashed @ or % gobbles up the rest of the args - $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/; + 1 while $proto =~ s/(?name =~ /^s?refgen$/ and !null($real = $arg->first) and - ($chr eq "\$" && is_scalar($real->first) - or ($chr eq "\@" + ($chr =~ /\$/ && is_scalar($real->first) + or ($chr =~ /@/ + && class($real->first->sibling) ne 'NULL' && $real->first->sibling->name =~ /^(rv2|pad)av$/) - or ($chr eq "%" + or ($chr =~ /%/ + && class($real->first->sibling) ne 'NULL' && $real->first->sibling->name =~ /^(rv2|pad)hv$/) - #or ($chr eq "&" # This doesn't work + #or ($chr =~ /&/ # This doesn't work # && $real->first->name eq "rv2cv") - or ($chr eq "*" + or ($chr =~ /\*/ && $real->first->name eq "rv2gv"))) { push @reals, $self->deparse($real, 6); @@ -2959,10 +2918,21 @@ sub pp_entersub { # Doesn't matter how many prototypes there are, if # they haven't happened yet! - my $declared = exists $self->{'subs_declared'}{$kid}; - if (!$declared && defined($proto)) { - # Avoid "too early to check prototype" warning - ($amper, $proto) = ('&'); + my $declared; + { + no strict 'refs'; + no warnings 'uninitialized'; + $declared = exists $self->{'subs_declared'}{$kid} + || ( + defined &{ %{$self->{'curstash'}."::"}->{$kid} } + && !exists + $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid} + && defined prototype $self->{'curstash'}."::".$kid + ); + if (!$declared && defined($proto)) { + # Avoid "too early to check prototype" warning + ($amper, $proto) = ('&'); + } } my $args; @@ -3053,7 +3023,7 @@ sub re_uninterp { | \\[uUlLQE] ) - /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg; + /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg; return $str; } @@ -3077,29 +3047,64 @@ sub re_uninterp_extended { | \#[^\n]* # (skip over comments) ) | [\$\@] - (?!\||\)|\(|$) + (?!\||\)|\(|$|\s) | \\[uUlLQE] ) - /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg; + /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg; return $str; } } +my %unctrl = # portable to to EBCDIC + ( + "\c@" => '\c@', # unused + "\cA" => '\cA', + "\cB" => '\cB', + "\cC" => '\cC', + "\cD" => '\cD', + "\cE" => '\cE', + "\cF" => '\cF', + "\cG" => '\cG', + "\cH" => '\cH', + "\cI" => '\cI', + "\cJ" => '\cJ', + "\cK" => '\cK', + "\cL" => '\cL', + "\cM" => '\cM', + "\cN" => '\cN', + "\cO" => '\cO', + "\cP" => '\cP', + "\cQ" => '\cQ', + "\cR" => '\cR', + "\cS" => '\cS', + "\cT" => '\cT', + "\cU" => '\cU', + "\cV" => '\cV', + "\cW" => '\cW', + "\cX" => '\cX', + "\cY" => '\cY', + "\cZ" => '\cZ', + "\c[" => '\c[', # unused + "\c\\" => '\c\\', # unused + "\c]" => '\c]', # unused + "\c_" => '\c_', # unused + ); + # character escapes, but not delimiters that might need to be escaped sub escape_str { # ASCII, UTF8 my($str) = @_; - $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; + $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; $str =~ s/\a/\\a/g; -# $str =~ s/\cH/\\b/g; # \b means someting different in a regex +# $str =~ s/\cH/\\b/g; # \b means something different in a regex $str =~ s/\t/\\t/g; $str =~ s/\n/\\n/g; $str =~ s/\e/\\e/g; $str =~ s/\f/\\f/g; $str =~ s/\r/\\r/g; - $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge; - $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge; + $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge; + $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge; return $str; } @@ -3107,8 +3112,9 @@ sub escape_str { # ASCII, UTF8 # Leave whitespace unmangled. sub escape_extended_re { my($str) = @_; - $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; - $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge; + $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; + $str =~ s/([[:^print:]])/ + ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge; $str =~ s/\n/\n\f/g; return $str; } @@ -3126,7 +3132,7 @@ sub re_unback { my($str) = @_; # the insane complexity here is due to the behaviour of "\c\" - $str =~ s/(^|[^\\]|\\c\\)(?precomp))); } } elsif ($kid->name ne 'regcomp') { - Carp::cluck("found ".$kid->name." where regcomp expected"); + carp("found ".$kid->name." where regcomp expected"); } else { ($re, $quote) = $self->regcomp($kid, 1, $extended); } @@ -3681,7 +3688,10 @@ sub pp_split { my($op, $cx) = @_; my($kid, @exprs, $ary, $expr); $kid = $op->first; - if ($ {$kid->pmreplroot}) { + # under ithreads pmreplroot is an integer, not an SV + my $replroot = $kid->pmreplroot; + if ( ( ref($replroot) && $$replroot ) || + ( !ref($replroot) && $replroot ) ) { $ary = $self->stash_variable('@', $self->gv_name($kid->pmreplroot)); } for (; !null($kid); $kid = $kid->sibling) { @@ -3735,7 +3745,7 @@ sub pp_subst { $flags .= "e"; } if ($op->pmflags & PMf_EVAL) { - $repl = $self->deparse($repl, 0); + $repl = $self->deparse($repl, 0, 1); } else { $repl = $self->dq($repl); } @@ -3832,6 +3842,22 @@ C will print which probably isn't what you intended (the C<'???'> is a sign that perl optimized away a constant value). +=item B<-P> + +Disable prototype checking. With this option, all function calls are +deparsed as if no prototype was defined for them. In other words, + + perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x' + +will print + + sub foo (\@) { + 1; + } + &foo(\@x); + +making clear how the parameters are actually passed to C. + =item B<-q> Expand double-quoted strings into the corresponding combinations of