X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/bb16bae836f8e26795fbfac1361bf85da0d6a912..e38acfd7c47f53eee8797f81f9039529d0bbfac1:/dist/B-Deparse/Deparse.pm?ds=sidebyside diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm index bec809e..cb54b95 100644 --- a/dist/B-Deparse/Deparse.pm +++ b/dist/B-Deparse/Deparse.pm @@ -14,7 +14,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring 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 + OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpSORT_REVERSE SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG CVf_METHOD CVf_LVALUE @@ -25,8 +25,10 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring ($] < 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.01; + ($] < 5.013 ? () : 'PMf_NONDESTRUCT'), + ($] < 5.015003 ? qw(OPpCONST_ARYBASE) : ()), + ($] < 5.015005 ? () : qw(OPpEVAL_BYTES)); +$VERSION = "1.09"; use strict; use vars qw/$AUTOLOAD/; use warnings (); @@ -36,7 +38,7 @@ BEGIN { # 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)) { + PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES)) { no strict 'refs'; *{$_} = sub () {0} unless *{$_}{CODE}; } @@ -46,7 +48,7 @@ BEGIN { # - 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 @@ -106,10 +108,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 @@ -167,7 +169,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 @@ -243,7 +245,8 @@ BEGIN { # # subs_declared # keys are names of subs for which we've printed declarations. -# That means we can omit parentheses from the arguments. +# That means we can omit parentheses from the arguments. It also means we +# need to put CORE:: on core functions of the same name. # # subs_deparsed # Keeps track of fully qualified names of all deparsed subs. @@ -480,7 +483,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) { @@ -736,7 +739,11 @@ sub ambient_pragmas { } elsif ($name eq '$[') { - $arybase = $val; + if (OPpCONST_ARYBASE) { + $arybase = $val; + } else { + croak "\$[ can't be non-zero on this perl" unless $val == 0; + } } elsif ($name eq 'integer' @@ -1017,12 +1024,13 @@ sub maybe_parens_unop { if ($name eq "umask" && $kid =~ /^\d+$/) { $kid = sprintf("%#o", $kid); } - return "$name($kid)"; + return $self->keyword($name) . "($kid)"; } else { $kid = $self->deparse($kid, 16); if ($name eq "umask" && $kid =~ /^\d+$/) { $kid = sprintf("%#o", $kid); } + $name = $self->keyword($name); if (substr($kid, 0, 1) eq "\cS") { # use kid's parens return $name . substr($kid, 1); @@ -1093,7 +1101,9 @@ sub maybe_my { my $self = shift; my($op, $cx, $text) = @_; if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { - my $my = $op->private & OPpPAD_STATE ? "state" : "my"; + my $my = $op->private & OPpPAD_STATE + ? $self->keyword("state") + : "my"; if (want_scalar($op)) { return "$my $text"; } else { @@ -1272,7 +1282,7 @@ Carp::confess() unless ref($gv) eq "B::GV"; # If a lexical with the same name is in scope, it may need to be # fully-qualified. sub stash_variable { - my ($self, $prefix, $name) = @_; + my ($self, $prefix, $name, $cx) = @_; return "$prefix$name" if $name =~ /::/; @@ -1281,6 +1291,18 @@ sub stash_variable { return "$prefix$name"; } + if ($name =~ /^[^\w+-]$/) { + if (defined $cx && $cx == 26) { + if ($prefix eq '@') { + return "$prefix\{$name}"; + } + elsif ($name eq '#') { return '${#}' } # "${#}a" vs "$#a" + } + if ($prefix eq '$#') { + return "\$#{$name}"; + } + } + my $v = ($prefix eq '$#' ? '@' : $prefix) . $name; return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v); return "$prefix$name"; @@ -1402,7 +1424,7 @@ sub pp_nextstate { $self->{'curstash'} = $stash; } - if ($self->{'arybase'} != $op->arybase) { + if (OPpCONST_ARYBASE && $self->{'arybase'} != $op->arybase) { push @text, '$[ = '. $op->arybase .";\n"; $self->{'arybase'} = $op->arybase; } @@ -1521,10 +1543,44 @@ sub pp_setstate { pp_nextstate(@_) } sub pp_unstack { return "" } # see also leaveloop +my %feature_keywords = ( + # keyword => 'feature', + state => 'state', + say => 'say', + given => 'switch', + when => 'switch', + default => 'switch', + break => 'switch', + evalbytes=>'evalbytes', +); + +sub keyword { + my $self = shift; + my $name = shift; + return $name if $name =~ /^CORE::/; # just in case + if (exists $feature_keywords{$name}) { + return "CORE::$name" + if !$self->{'hinthash'} + || !$self->{'hinthash'}{"feature_$feature_keywords{$name}"} + } + if ( + $name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/ + && !defined eval{prototype "CORE::$name"} + ) { return $name } + if ( + exists $self->{subs_declared}{$name} + or + exists &{"$self->{curstash}::$name"} + ) { + return "CORE::$name" + } + return $name; +} + sub baseop { my $self = shift; my($op, $cx, $name) = @_; - return $name; + return $self->keyword($name); } sub pp_stub { @@ -1600,7 +1656,7 @@ sub pp_not { my $self = shift; my($op, $cx) = @_; if ($cx <= 4) { - $self->pfixop($op, $cx, "not ", 4); + $self->pfixop($op, $cx, $self->keyword("not")." ", 4); } else { $self->pfixop($op, $cx, "!", 21); } @@ -1626,7 +1682,8 @@ sub unop { return $self->maybe_parens_unop($name, $kid, $cx); } else { - return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); + return $self->keyword($name) + . ($op->flags & OPf_SPECIAL ? "()" : ""); } } @@ -1659,6 +1716,7 @@ sub pp_chr { maybe_targmy(@_, \&unop, "chr") } sub pp_each { unop(@_, "each") } sub pp_values { unop(@_, "values") } sub pp_keys { unop(@_, "keys") } +{ no strict 'refs'; *{"pp_r$_"} = *{"pp_$_"} for qw< keys each values >; } sub pp_boolkeys { # no name because its an optimisation op that has no keyword unop(@_,""); @@ -1701,7 +1759,12 @@ sub pp_alarm { unop(@_, "alarm") } sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") } sub pp_dofile { unop(@_, "do") } -sub pp_entereval { unop(@_, "eval") } +sub pp_entereval { + unop( + @_, + $_[1]->private & OPpEVAL_BYTES ? $_[0]->keyword('evalbytes') : "eval" + ) +} sub pp_ghbyname { unop(@_, "gethostbyname") } sub pp_gnbyname { unop(@_, "getnetbyname") } @@ -1718,11 +1781,7 @@ sub pp_ggrgid { unop(@_, "getgrgid") } sub pp_lock { unop(@_, "lock") } sub pp_continue { unop(@_, "continue"); } -sub pp_break { - my ($self, $op) = @_; - return "" if $op->flags & OPf_SPECIAL; - unop(@_, "break"); -} +sub pp_break { unop(@_, "break"); } sub givwhen { my $self = shift; @@ -1731,7 +1790,7 @@ sub givwhen { my $enterop = $op->first; my ($head, $block); if ($enterop->flags & OPf_SPECIAL) { - $head = "default"; + $head = $self->keyword("default"); $block = $self->deparse($enterop->first, 0); } else { @@ -1746,8 +1805,8 @@ sub givwhen { "\b}\cK"; } -sub pp_leavegiven { givwhen(@_, "given"); } -sub pp_leavewhen { givwhen(@_, "when"); } +sub pp_leavegiven { givwhen(@_, $_[0]->keyword("given")); } +sub pp_leavewhen { givwhen(@_, $_[0]->keyword("when")); } sub pp_exists { my $self = shift; @@ -1950,7 +2009,7 @@ sub pp_last { loopex(@_, "last") } sub pp_next { loopex(@_, "next") } sub pp_redo { loopex(@_, "redo") } sub pp_goto { loopex(@_, "goto") } -sub pp_dump { loopex(@_, "dump") } +sub pp_dump { loopex(@_, $_[0]->keyword("dump")) } sub ftst { my $self = shift; @@ -2283,9 +2342,10 @@ sub listop { my(@exprs); my $parens = ($cx >= 5) || $self->{'parens'}; my $kid = $op->first->sibling; - return $name if null $kid; + return $self->keyword($name) if null $kid; my $first; $name = "socketpair" if $name eq "sockpair"; + my $fullname = $self->keyword($name); my $proto = prototype("CORE::$name"); if (defined $proto && $proto =~ /^;?\*/ @@ -2309,12 +2369,13 @@ sub listop { push @exprs, $self->deparse($kid, 6); } if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) { - return "$exprs[0] = $name" . ($parens ? "($exprs[0])" : " $exprs[0]"); + return "$exprs[0] = $fullname" + . ($parens ? "($exprs[0])" : " $exprs[0]"); } if ($parens) { - return "$name(" . join(", ", @exprs) . ")"; + return "$fullname(" . join(", ", @exprs) . ")"; } else { - return "$name " . join(", ", @exprs); + return "$fullname " . join(", ", @exprs); } } @@ -2405,9 +2466,12 @@ sub pp_glob { my $self = shift; my($op, $cx) = @_; my $text = $self->dq($op->first->sibling); # skip pushmark + my $keyword = + $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob'); if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline - or $text =~ /[<>]/) { - return 'glob(' . single_delim('qq', '"', $text) . ')'; + or $keyword =~ /^CORE::/ + or $text =~ /[<>]/) { + return "$keyword(" . single_delim('qq', '"', $text) . ')'; } else { return '<' . $text . '>'; } @@ -2432,10 +2496,11 @@ sub pp_truncate { $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "("; } my $len = $self->deparse($kid->sibling, 6); + my $name = $self->keyword('truncate'); if ($parens) { - return "truncate($fh, $len)"; + return "$name($fh, $len)"; } else { - return "truncate $fh, $len"; + return "$name $fh, $len"; } } @@ -2470,10 +2535,11 @@ sub indirop { $expr = $self->deparse($kid, 6); push @exprs, $expr; } - my $name2 = $name; + my $name2; if ($name eq "sort" && $op->private & OPpSORT_REVERSE) { - $name2 = 'reverse sort'; + $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort'); } + else { $name2 = $self->keyword($name) } if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) { return "$exprs[0] = $name2 $indir $exprs[0]"; } @@ -2532,6 +2598,7 @@ sub pp_list { my($op, $cx) = @_; my($expr, @exprs); my $kid = $op->first->sibling; # skip pushmark + return '' if class($kid) eq 'NULL'; my $lop; my $local = "either"; # could be local(...), my(...), state(...) or our(...) for ($lop = $kid; !null($lop); $lop = $lop->sibling) { @@ -2783,10 +2850,9 @@ sub pp_leavetry { return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}"; } -BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" } -BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" } -BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" } -BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" } +BEGIN { for (qw[ const stringify rv2sv list glob ]) { + eval "sub OP_\U$_ () { " . opnumber($_) . "}" +}} sub pp_null { my $self = shift; @@ -2804,6 +2870,14 @@ sub pp_null { return $self->pp_scope($op->first, $cx); } elsif ($op->targ == OP_STRINGIFY) { return $self->dquote($op, $cx); + } elsif ($op->targ == OP_GLOB) { + return $self->pp_glob( + $op->first # entersub + ->first # ex-list + ->first # pushmark + ->sibling, # glob + $cx + ); } elsif (!null($op->first->sibling) and $op->first->sibling->name eq "readline" and $op->first->sibling->flags & OPf_STACKED) { @@ -2874,7 +2948,7 @@ sub pp_gvsv { my($op, $cx) = @_; my $gv = $self->gv_or_padgv($op); return $self->maybe_local($op, $cx, $self->stash_variable("\$", - $self->gv_name($gv))); + $self->gv_name($gv), $cx)); } sub pp_gv { @@ -2884,22 +2958,25 @@ sub pp_gv { return $self->gv_name($gv); } +sub pp_aelemfast_lex { + my $self = shift; + my($op, $cx) = @_; + my $name = $self->padname($op->targ); + $name =~ s/^@/\$/; + return $name . "[" . ($op->private + $self->{'arybase'}) . "]"; +} + sub pp_aelemfast { my $self = shift; my($op, $cx) = @_; - my $name; - if ($op->flags & OPf_SPECIAL) { # optimised PADAV - $name = $self->padname($op->targ); - $name =~ s/^@/\$/; - } - else { - my $gv = $self->gv_or_padgv($op); - $name = $self->gv_name($gv); - $name = $self->{'curstash'}."::$name" - if $name !~ /::/ && $self->lex_in_scope('@'.$name); - $name = '$' . $name; - } + # optimised PADAV, pre 5.15 + return $self->pp_aelemfast_lex(@_) if ($op->flags & OPf_SPECIAL); + my $gv = $self->gv_or_padgv($op); + my $name = $self->gv_name($gv); + $name = $self->{'curstash'}."::$name" + if $name !~ /::/ && $self->lex_in_scope('@'.$name); + $name = '$' . $name; return $name . "[" . ($op->private + $self->{'arybase'}) . "]"; } @@ -2913,7 +2990,7 @@ sub rv2x { } my $kid = $op->first; if ($kid->name eq "gv") { - return $self->stash_variable($type, $self->deparse($kid, 0)); + return $self->stash_variable($type, $self->deparse($kid, 0), $cx); } elsif (is_scalar $kid) { my $str = $self->deparse($kid, 0); if ($str =~ /^\$([^\w\d])\z/) { @@ -3189,7 +3266,7 @@ sub _method { } else { $obj = $kid; $kid = $kid->sibling; - for (; !null ($kid->sibling) && $kid->name ne "method_named"; + for (; !null ($kid->sibling) && $kid->name!~/^method(?:_named)?\z/; $kid = $kid->sibling) { push @exprs, $kid } @@ -3393,15 +3470,7 @@ 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, + # It's a syntax error to call CORE::GLOBAL::foo with a prefix, # so it must have been translated from a keyword call. Translate # it back. $kid =~ s/^CORE::GLOBAL:://; @@ -3838,7 +3907,10 @@ sub pp_backtick { # skip pushmark if it exists (readpipe() vs ``) my $child = $op->first->sibling->isa('B::NULL') ? $op->first : $op->first->sibling; - return single_delim("qx", '`', $self->dq($child)); + if ($self->pure_string($child)) { + return single_delim("qx", '`', $self->dq($child, 1)); + } + unop($self, @_, "readpipe"); } sub dquote { @@ -4087,13 +4159,17 @@ 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 = ""; - my $priv_flags = $op->private; $flags .= "c" if $priv_flags & OPpTRANS_COMPLEMENT; $flags .= "d" if $priv_flags & OPpTRANS_DELETE; $to = "" if $from eq $to and $flags eq ""; @@ -4302,7 +4378,7 @@ sub pp_split { } elsif (!ref($replroot) and $replroot > 0) { $gv = $self->padval($replroot); } - $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv; + $ary = $self->stash_variable('@', $self->gv_name($gv), $cx) if $gv; for (; !null($kid); $kid = $kid->sibling) { push @exprs, $self->deparse($kid, 6); @@ -4730,6 +4806,7 @@ expect. =item $[ Takes a number, the value of the array base $[. +Cannot be non-zero on Perl 5.15.3 or later. =item bytes @@ -4841,14 +4918,6 @@ from the Perl core to fix. =item * -If a keyword is over-ridden, and your program explicitly calls -the built-in version by using CORE::keyword, the output of B::Deparse -will not reflect this. If you run the resulting code, it will call -the over-ridden version rather than the built-in one. (Maybe there -should be an option to B print keyword calls as C.) - -=item * - Some constants don't print correctly either with or without B<-d>. For instance, neither B::Deparse nor Data::Dumper know how to print dual-valued scalars correctly, as in: @@ -4881,7 +4950,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 is a good start. =item *