package B::Deparse;
use Carp 'cluck';
-use B qw(class main_root main_start main_cv svref_2object);
-$VERSION = 0.55;
+use B qw(class main_root main_start main_cv svref_2object opnumber
+ OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
+ OPpENTERSUB_AMPER OPf_KIDS OPpLVAL_INTRO
+ OPf_SPECIAL OPpSLICE OPpCONST_BARE OPf_REF OPf_STACKED
+ OPpENTERSUB_AMPER OPpTRANS_SQUASH OPpTRANS_DELETE
+ OPpTRANS_COMPLEMENT SVf_IOK SVf_NOK SVf_ROK SVf_POK
+ PMf_ONCE PMf_SKIPWHITE PMf_CONST PMf_KEEP PMf_GLOBAL PMf_CONTINUE
+ PMf_EVAL PMf_LOCALE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED
+ );
+$VERSION = 0.561;
use strict;
# Changes between 0.50 and 0.51:
# Changes between 0.54 and 0.55
# - added support for new qr// construct
# - added support for new pp_regcreset OP
+# Changes between 0.55 and 0.56
+# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
+# - fixed $# on non-lexicals broken in last big rewrite
+# - added temporary fix for change in opcode of OP_STRINGIFY
+# - fixed problem in 0.54's for() patch in `for (@ary)'
+# - fixed precedence in conditional of ?:
+# - tweaked list paren elimination in `my($x) = @_'
+# - made continue-block detection trickier wrt. null ops
+# - fixed various prototype problems in pp_entersub
+# - added support for sub prototypes that never get GVs
+# - added unquoting for special filehandle first arg in truncate
+# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
+# - added semicolons at the ends of blocks
+# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
# Todo:
# - {} around variables in strings ("${var}letters")
+# base/lex.t 25-27
+# comp/term.t 11
+# - generate symbolic constants directly from core source
# - left/right context
+# - avoid semis in one-statement blocks
# - associativity of &&=, ||=, ?:
# - ',' => '=>' (auto-unquote?)
# - break long lines ("\r" as discretionary break?)
+# - include values of variables (e.g. set in BEGIN)
+# - coordinate with Data::Dumper (both directions? see previous)
# - version using op_next instead of op_first/sibling?
# - avoid string copies (pass arrays, one big join?)
# - auto-apply `-u'?
# - here-docs?
# - <DATA>?
+# Tests that will always fail:
+# comp/redef.t -- all (redefinition happens at compile time)
+
# Object fields (were globals):
#
# avoid_local:
# array of [cop_seq, GV, is_format?] for subs and formats we still
# want to deparse
#
+# protos_todo:
+# as above, but [name, prototype] for subs that never got a GV
+#
# subs_done, forms_done:
# keys are addresses of GVs for subs and formats we've already
# deparsed (or at least put into subs_todo)
#
# parens: -p
+# linenums: -l
# cuddle: ` ' or `\n', depending on -sC
# A little explanation of how precedence contexts and associativity
# deparse() calls each per-op subroutine with an argument $cx (short
# for context, but not the same as the cx* in the perl core), which is
# a number describing the op's parents in terms of precedence, whether
-# they're inside and expression or at statement level, etc. (see
+# they're inside an expression or at statement level, etc. (see
# chart below). When ops with children call deparse on them, they pass
# along their precedence. Fractional values are used to implement
# associativity (`($x + $y) + $z' => `$x + $y + $y') and related
# \n - newline and indent
# \t - increase indent
# \b - decrease indent (`outdent')
+# \f - flush left (no indent)
# \cK - kill following semicolon, if any
sub null {
}
}
-sub OPf_KIDS () { 4 }
sub walk_tree {
my($op, $sub) = @_;
my $pack = shift;
my(%stash, @ret);
{ no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
+ if ($pack eq "main") {
+ $pack = "";
+ } else {
+ $pack = $pack . "::";
+ }
my($key, $val);
while (($key, $val) = each %stash) {
- next unless class($val) eq "GV";
- if (class($val->CV) ne "SPECIAL") {
- next if $self->{'subs_done'}{$$val}++;
- $self->todo($val, $val->CV, 0);
- $self->walk_sub($val->CV);
- }
- if (class($val->FORM) ne "SPECIAL") {
- next if $self->{'forms_done'}{$$val}++;
- $self->todo($val, $val->FORM, 1);
- $self->walk_sub($val->FORM);
+ my $class = class($val);
+ if ($class eq "PV") {
+ # Just a prototype
+ push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
+ } elsif ($class eq "IV") {
+ # Just a name
+ push @{$self->{'protos_todo'}}, [$pack . $key, undef];
+ } elsif ($class eq "GV") {
+ if (class($val->CV) ne "SPECIAL") {
+ next if $self->{'subs_done'}{$$val}++;
+ $self->todo($val, $val->CV, 0);
+ $self->walk_sub($val->CV);
+ }
+ if (class($val->FORM) ne "SPECIAL") {
+ next if $self->{'forms_done'}{$$val}++;
+ $self->todo($val, $val->FORM, 1);
+ $self->walk_sub($val->FORM);
+ }
}
}
}
+sub print_protos {
+ my $self = shift;
+ my $ar;
+ my @ret;
+ foreach $ar (@{$self->{'protos_todo'}}) {
+ my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
+ push @ret, "sub " . $ar->[0] . "$proto;\n";
+ }
+ delete $self->{'protos_todo'};
+ return @ret;
+}
+
sub style_opts {
my $self = shift;
my $opts = shift;
$self->stash_subs(substr($arg, 2));
} elsif ($arg eq "-p") {
$self->{'parens'} = 1;
+ } elsif ($arg eq "-l") {
+ $self->{'linenums'} = 1;
} elsif (substr($arg, 0, 2) eq "-s") {
$self->style_opts(substr $arg, 2);
}
}
$self->walk_sub(main_cv, main_start);
+ print $self->print_protos;
@{$self->{'subs_todo'}} =
sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
print indent($self->deparse(main_root, 0)), "\n" unless null main_root;
$leader = substr($leader, 0, length($leader) - 4);
$line = substr($line, 1);
}
+ if (substr($line, 0, 1) eq "\f") {
+ $line = substr($line, 1); # no indent
+ } else {
+ $line = $leader . $line;
+ }
$line =~ s/\cK;?//g;
- $line = $leader . $line;
}
return join("\n", @lines);
}
-sub SVf_POK () {0x40000}
sub deparse_sub {
my $self = shift;
}
}
-sub OPp_LVAL_INTRO () { 128 }
sub maybe_local {
my $self = shift;
my($op, $cx, $text) = @_;
- if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
+ if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
return $self->maybe_parens_func("local", $text, $cx, 16);
} else {
return $text;
sub maybe_my {
my $self = shift;
my($op, $cx, $text) = @_;
- if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
+ if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
return $self->maybe_parens_func("my", $text, $cx, 16);
} else {
return $text;
if ($cx > 0) { # inside an expression
return "do { " . join(";\n", @exprs) . " }";
} else {
- return join(";\n", @exprs);
+ return join(";\n", @exprs) . ";";
}
}
if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
return "do { " . join(";\n", @exprs) . " }";
} else {
- return join(";\n", @exprs);
+ return join(";\n", @exprs) . ";";
}
}
push @text, "package $stash;\n";
$self->{'curstash'} = $stash;
}
+ if ($self->{'linenums'}) {
+ push @text, "\f#line " . $op->line .
+ ' "' . substr($op->filegv->NAME, 2), qq'"\n';
+ }
return join("", @text);
}
}
}
-sub OPf_SPECIAL () { 128 }
sub unop {
my $self = shift;
$cx, 16);
}
-sub OPpSLICE () { 64 }
-
sub pp_delete {
my $self = shift;
my($op, $cx) = @_;
}
}
-sub OPp_CONST_BARE () { 64 }
-
sub pp_require {
my $self = shift;
my($op, $cx) = @_;
if (class($op) eq "UNOP" and $op->first->ppaddr eq "pp_const"
- and $op->first->private & OPp_CONST_BARE)
+ and $op->first->private & OPpCONST_BARE)
{
my $name = $op->first->sv->PV;
$name =~ s[/][::]g;
return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
}
-sub OPf_REF () { 16 }
-
sub pp_refgen {
my $self = shift;
my($op, $cx) = @_;
sub SWAP_CHILDREN () { 1 }
sub ASSIGN () { 2 } # has OP= variant
-sub OPf_STACKED () { 64 }
-
my(%left, %right);
sub assoc_class {
sub pp_send { listop(@_, "send") }
sub pp_recv { listop(@_, "recv") }
sub pp_seek { listop(@_, "seek") }
-sub pp_truncate { listop(@_, "truncate") }
sub pp_fcntl { listop(@_, "fcntl") }
sub pp_ioctl { listop(@_, "ioctl") }
sub pp_flock { listop(@_, "flock") }
}
}
+# Truncate is special because OPf_SPECIAL makes a bareword first arg
+# be a filehandle. This could probably be better fixed in the core
+# by moving the GV lookup into ck_truc.
+
+sub pp_truncate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my(@exprs);
+ my $parens = ($cx >= 5) || $self->{'parens'};
+ my $kid = $op->first->sibling;
+ my $fh;
+ if ($op->flags & OPf_SPECIAL) {
+ # $kid is an OP_CONST
+ $fh = $kid->sv->PV;
+ } else {
+ $fh = $self->deparse($kid, 6);
+ $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
+ }
+ my $len = $self->deparse($kid->sibling, 6);
+ if ($parens) {
+ return "truncate($fh, $len)";
+ } else {
+ return "truncate $fh, $len";
+ }
+
+}
+
sub indirop {
my $self = shift;
my($op, $cx, $name) = @_;
my($op, $cx) = @_;
my($expr, @exprs);
my $kid = $op->first->sibling; # skip pushmark
- return $self->deparse($kid, $cx) if null $kid->sibling;
my $lop;
my $local = "either"; # could be local(...) or my(...)
for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
# This assumes that no other private flags equal 128, and that
# OPs that store things other than flags in their op_private,
# like OP_AELEMFAST, won't be immediate children of a list.
- unless ($lop->private & OPp_LVAL_INTRO or $lop->ppaddr eq "pp_undef")
+ unless ($lop->private & OPpLVAL_INTRO or $lop->ppaddr eq "pp_undef")
{
$local = ""; # or not
last;
}
}
$local = "" if $local eq "either"; # no point if it's all undefs
+ return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
for (; !null($kid); $kid = $kid->sibling) {
if ($local) {
if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") {
my $true = $cond->sibling;
my $false = $true->sibling;
my $cuddle = $self->{'cuddle'};
- $cond = $self->deparse($cond, 1);
unless ($cx == 0 and is_scope($true) and is_scope($false)) {
+ $cond = $self->deparse($cond, 8);
$true = $self->deparse($true, 8);
$false = $self->deparse($false, 8);
return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
}
+ $cond = $self->deparse($cond, 1);
$true = $self->deparse($true, 0);
if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif
my $head = "if ($cond) {\n\t$true\n\b}";
} elsif ($enter->ppaddr eq "pp_enteriter") { # foreach
my $ary = $enter->first->sibling; # first was pushmark
my $var = $ary->sibling;
- if ($enter->flags & OPf_STACKED) {
+ if ($enter->flags & OPf_STACKED
+ and not null $ary->first->sibling->sibling)
+ {
$ary = $self->deparse($ary->first->sibling, 9) . " .. " .
$self->deparse($ary->first->sibling->sibling, 9);
} else {
# the op_next of the head of the _previous_ statement.
# Unless it's a bare loop, in which case it's last, since there's
# no unstack or extra nextstate.
+ # Except if the previous head isn't null but the first kid is
+ # (because it's a nulled out nextstate in a scope), in which
+ # case the head's next is advanced past the null but the nextop's
+ # isn't, so we need to try nextop->next.
my($cont, $precont);
if ($bare) {
$cont = $kid->first;
$cont = $cont->sibling;
}
}
-# cluck $self->{'curcv'}->GV->NAME unless $precont;
- if ($precont and $ {$precont->next} == $ {$enter->nextop}) {
- my $state = $kid->first;
- my $cuddle = $self->{'cuddle'};
- my($expr, @exprs);
- for (; $$state != $$cont; $state = $state->sibling) {
- $expr = "";
- if (is_state $state) {
- $expr = $self->deparse($state, 0);
- $state = $state->sibling;
- last if null $kid;
- }
- $expr .= $self->deparse($state, 0);
- push @exprs, $expr if $expr;
- }
- $kid = join(";\n", @exprs);
- $cont = $cuddle . "continue {\n\t" .
- $self->deparse($cont, 0) . "\n\b}\cK";
+ if ($precont and $ {$precont->next} == $ {$enter->nextop}
+ || $ {$precont->next} == $ {$enter->nextop->next} )
+ {
+ my $state = $kid->first;
+ my $cuddle = $self->{'cuddle'};
+ my($expr, @exprs);
+ for (; $$state != $$cont; $state = $state->sibling) {
+ $expr = "";
+ if (is_state $state) {
+ $expr = $self->deparse($state, 0);
+ $state = $state->sibling;
+ last if null $kid;
+ }
+ $expr .= $self->deparse($state, 0);
+ push @exprs, $expr if $expr;
+ }
+ $kid = join(";\n", @exprs);
+ $cont = $cuddle . "continue {\n\t" .
+ $self->deparse($cont, 0) . "\n\b}\cK";
} else {
$cont = "\cK";
$kid = $self->deparse($kid, 0);
sub pp_leavetry {
my $self = shift;
return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
-}
+}
-sub OP_CONST () { 5 }
-sub OP_STRINGIFY () { 65 }
+my $OP_CONST = opnumber("const");
+my $OP_STRINGIFY = opnumber("stringify");
+# XXX need a better way to do this
sub pp_null {
my $self = shift;
my($op, $cx) = @_;
if (class($op) eq "OP") {
- return "'???'" if $op->targ == OP_CONST; # old value is lost
+ return "'???'" if $op->targ == $OP_CONST; # old value is lost
} elsif ($op->first->ppaddr eq "pp_pushmark") {
return $self->pp_list($op, $cx);
} elsif ($op->first->ppaddr eq "pp_enter") {
return $self->pp_leave($op, $cx);
- } elsif ($op->targ == OP_STRINGIFY) {
+ } elsif ($op->targ == $OP_STRINGIFY) {
return $self->dquote($op);
} elsif (!null($op->first->sibling) and
$op->first->sibling->ppaddr eq "pp_readline" and
my $self = shift;
my($op, $cx, $type) = @_;
my $kid = $op->first;
- my $scope = is_scope($kid);
- $kid = $self->deparse($kid, 0);
- return $type . ($scope ? "{$kid}" : $kid);
+ my $str = $self->deparse($kid, 0);
+ return $type . (is_scalar($kid) ? $str : "{$str}");
}
sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
if ($op->first->ppaddr eq "pp_padav") {
return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
} else {
- return $self->maybe_local($op, $cx, $self->rv2x($op->first, '$#'));
+ return $self->maybe_local($op, $cx,
+ $self->rv2x($op->first, $cx, '$#'));
}
}
return "($list)" . "[$idx]";
}
-sub OPpENTERSUB_AMPER () { 8 }
-
-sub OPf_WANT () { 3 }
-sub OPf_WANT_VOID () { 1 }
-sub OPf_WANT_SCALAR () { 2 }
-sub OPf_WANT_LIST () { 2 }
-
sub want_scalar {
my $op = shift;
return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
my $doneok = 0;
my @args = @exprs;
my @reals;
- $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
- while ($proto) {
- $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
+ my $p = $proto;
+ $p =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
+ while ($p) {
+ $p =~ s/^ *([\\]?[\$\@&%*]|;)//;
my $chr = $1;
if ($chr eq "") {
undef $proto if @args;
@args = ();
} else {
$arg = shift @args;
- undef $proto, last unless $arg;
+ last unless $arg;
if ($chr eq "\$") {
if (want_scalar $arg) {
push @reals, $self->deparse($arg, 6);
}
}
}
- undef $proto if $proto and !$doneok;
+ undef $proto if $p and !$doneok;
undef $proto if @args;
$args = join(", ", @reals);
$amper = "";
}
}
-sub SVf_IOK () {0x10000}
-sub SVf_NOK () {0x20000}
-sub SVf_ROK () {0x80000}
sub const {
my $sv = shift;
sub pp_const {
my $self = shift;
my($op, $cx) = @_;
-# if ($op->private & OPp_CONST_BARE) { # trouble with `=>' autoquoting
+# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
# return $op->sv->PV;
# }
return const($op->sv);
return $str;
}
-sub OPpTRANS_SQUASH () { 16 }
-sub OPpTRANS_DELETE () { 32 }
-sub OPpTRANS_COMPLEMENT () { 64 }
-
sub pp_trans {
my $self = shift;
my($op, $cx) = @_;
return $self->re_dq($kid);
}
-sub OPp_RUNTIME () { 64 }
-
-sub PMf_ONCE () { 0x2 }
-sub PMf_SKIPWHITE () { 0x10 }
-sub PMf_CONST () { 0x40 }
-sub PMf_KEEP () { 0x80 }
-sub PMf_GLOBAL () { 0x100 }
-sub PMf_CONTINUE () { 0x200 }
-sub PMf_EVAL () { 0x400 }
-sub PMf_LOCALE () { 0x800 }
-sub PMf_MULTILINE () { 0x1000 }
-sub PMf_SINGLELINE () { 0x2000 }
-sub PMf_FOLD () { 0x4000 }
-sub PMf_EXTENDED () { 0x8000 }
# osmic acid -- see osmium tetroxide
=head1 SYNOPSIS
-B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-s>I<LETTERS>] I<prog.pl>
+B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-l>][B<,-s>I<LETTERS>] I<prog.pl>
=head1 DESCRIPTION
(yet) try to guess automatically when B<-u> is needed -- you must
invoke it yourself.
+=item B<-l>
+
+Add '#line' declarations to the output based on the line and file
+locations of the original code.
+
=item B<-s>I<LETTERS>
Tweak the style of B::Deparse's output. At the moment, only one style
projects / p5sagit/p5-mst-13.2.git / blobdiff