# B::Deparse.pm
-# Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved.
+# Copyright (c) 1998-2000, 2002, 2003 Stephen McCamant. All rights reserved.
# This module is free software; you can redistribute and/or modify
# it under the same terms as Perl itself.
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_FAKE SVs_RMG
+ SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_ASSERTION
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = 0.63;
+$VERSION = 0.64;
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
# - preliminary version of utf8 tr/// handling
# Changes after 0.58:
# - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
-# - added support for Hugo's new OP_SETSTATE (like nextstate)
+# - added support for Hugo's new OP_SETSTATE (like nextstate)
# Changes between 0.58 and 0.59
# - added support for Chip's OP_METHOD_NAMED
# - added support for Ilya's OPpTARGET_MY optimization
# - bug-fixes
# - new switch -P
# - support for command-line switches (-l, -0, etc.)
+# Changes between 0.63 and 0.64
+# - support for //, CHECK blocks, and assertions
+# - improved handling of foreach loops and lexicals
+# - option to use Data::Dumper for constants
+# - more bug fixes
+# - discovered lots more bugs not yet fixed
# Todo:
# (See also BUGS section at the end of this file)
# - finish tr/// changes
# - add option for even more parens (generalize \&foo change)
# - left/right context
-# - treat top-level block specially for incremental output
# - copy comments (look at real text with $^P?)
# - avoid semis in one-statement blocks
# - associativity of &&=, ||=, ?:
# - more style options: brace style, hex vs. octal, quotes, ...
# - print big ints as hex/octal instead of decimal (heuristic?)
# - handle `my $x if 0'?
-# - 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?)
# - here-docs?
-# Tests that will always fail:
-# (see t/TEST for the short list)
+# Current test.deparse failures
+# comp/assertions 38 - disabled assertions should be like "my($x) if 0"
+# 'sub f : assertion {}; no assertions; my $x=1; {f(my $x=2); print "$x\n"}'
+# comp/hints 6 - location of BEGIN blocks wrt. block openings
+# run/switchI 1 - missing -I switches entirely
+# perl -Ifoo -e 'print @INC'
+# op/caller 2 - warning mask propagates backwards before warnings::register
+# '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
+# '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
+# 'use charnames ":short"; $x="\N{latin:a with acute}"'
+# op/recurse 12 - missing parens on recursive call makes it look like method
+# 'sub f { f($x) }'
+# op/subst 90 - inconsistent handling of utf8 under "use utf8"
+# op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
+# op/tiehandle compile - "use strict" deparsed in the wrong place
+# uni/tr_ several
+# ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
+# ext/Data/Dumper/t/dumper compile
+# ext/DB_file/several
+# ext/Encode/several
+# ext/Ernno/Errno warnings
+# ext/IO/lib/IO/t/io_sel 23
+# ext/PerlIO/t/encoding compile
+# ext/POSIX/t/posix 6
+# ext/Socket/Socket 8
+# ext/Storable/t/croak compile
+# lib/Attribute/Handlers/t/multi compile
+# lib/bignum/ several
+# lib/charnames 35
+# lib/constant 32
+# lib/English 40
+# lib/ExtUtils/t/bytes 4
+# lib/File/DosGlob compile
+# lib/Filter/Simple/t/data 1
+# lib/Math/BigInt/t/constant 1
+# lib/Net/t/config Deparse-warning
+# lib/overload compile
+# lib/Switch/ several
+# lib/Symbol 4
+# lib/Test/Simple several
+# lib/Term/Complete
+# lib/Tie/File/t/29_downcopy 5
+# lib/vars 22
# Object fields (were globals):
#
# (local($a), local($b)) and local($a, $b) have the same internal
# representation but the short form looks better. We notice we can
# use a large-scale local when checking the list, but need to prevent
-# individual locals too. This hash holds the addresses of OPs that
+# individual locals too. This hash holds the addresses of OPs that
# have already had their local-ness accounted for. The same thing
# is done with my().
#
# 3 left and
# 2 left or xor
# 1 statement modifiers
+# 0.5 statements, but still print scopes as do { ... }
# 0 statement level
-# Also, lineseq may pass a fourth parameter to the pp_ routines:
-# if present, the fourth parameter is passed on by deparse.
-#
-# If present and true, it means that the op exists directly as
-# part of a lineseq. Currently it's only used by scopeop to
-# decide whether its results need to be enclosed in a do {} block.
-
# Nonprinting characters with special meaning:
# \cS - steal parens (see maybe_parens_unop)
# \n - newline and indent
my($cv, $is_form) = @_;
return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
my $seq;
- if (!null($cv->START) and is_state($cv->START)) {
+ if ($cv->OUTSIDE_SEQ) {
+ $seq = $cv->OUTSIDE_SEQ;
+ } elsif (!null($cv->START) and is_state($cv->START)) {
$seq = $cv->START->cop_seq;
} else {
$seq = 0;
$self->{'subs_declared'}{$name} = 1;
if ($name eq "BEGIN") {
my $use_dec = $self->begin_is_use($cv);
- if (defined ($use_dec)) {
+ if (defined ($use_dec) and $self->{'expand'} < 5) {
return () if 0 == length($use_dec);
return $use_dec;
}
$module =~ s/.pm$//;
}
else {
- $module = const($self->const_sv($req_op->first));
+ $module = $self->const($self->const_sv($req_op->first), 6);
}
my $version;
return unless $self->const_sv($constop)->PV eq $module;
$constop = $constop->sibling;
$version = $self->const_sv($constop);
- if (class($version) ne "PVMG") {
- # version is either an integer or a double
+ if (class($version) eq "IV") {
+ $version = $version->int_value;
+ } elsif (class($version) eq "NV") {
+ $version = $version->NV;
+ } elsif (class($version) ne "PVMG") {
+ # Includes PVIV and PVNV
$version = $version->PV;
} else {
# version specified as a v-string
my $AF = $A->FILE;
next unless $AF eq $0 || exists $self->{'files'}{$AF};
}
- push @{$self->{'protos_todo'}}, [$pack . $key, undef];
+ push @{$self->{'protos_todo'}}, [$pack . $key, undef];
} elsif ($class eq "GV") {
if (class(my $cv = $val->CV) ne "SPECIAL") {
next if $self->{'subs_done'}{$$val}++;
sub new {
my $class = shift;
my $self = bless {}, $class;
- $self->{'subs_todo'} = [];
- $self->{'files'} = {};
- $self->{'curstash'} = "main";
- $self->{'curcop'} = undef;
$self->{'cuddle'} = "\n";
- $self->{'indent_size'} = 4;
- $self->{'use_tabs'} = 0;
+ $self->{'curcop'} = undef;
+ $self->{'curstash'} = "main";
+ $self->{'ex_const'} = "'???'";
$self->{'expand'} = 0;
- $self->{'unquote'} = 0;
+ $self->{'files'} = {};
+ $self->{'indent_size'} = 4;
$self->{'linenums'} = 0;
$self->{'parens'} = 0;
- $self->{'ex_const'} = "'???'";
+ $self->{'subs_todo'} = [];
+ $self->{'unquote'} = 0;
+ $self->{'use_dumper'} = 0;
+ $self->{'use_tabs'} = 0;
$self->{'ambient_arybase'} = 0;
$self->{'ambient_warnings'} = undef; # Assume no lexical warnings
$self->init();
while (my $arg = shift @_) {
- if ($arg =~ /^-f(.*)/) {
+ if ($arg eq "-d") {
+ $self->{'use_dumper'} = 1;
+ require Data::Dumper;
+ } elsif ($arg =~ /^-f(.*)/) {
$self->{'files'}{$1} = 1;
+ } elsif ($arg eq "-l") {
+ $self->{'linenums'} = 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") {
$self->{'unquote'} = 1;
} elsif (substr($arg, 0, 2) eq "-s") {
sub compile {
my(@args) = @_;
- return sub {
+ return sub {
my $self = B::Deparse->new(@args);
# First deparse command-line args
if (defined $^I) { # deparse -i
$self->todo($block, 0);
}
$self->stash_subs();
+ local($SIG{"__DIE__"}) =
+ sub {
+ if ($self->{'curcop'}) {
+ my $cop = $self->{'curcop'};
+ my($line, $file) = ($cop->line, $cop->file);
+ print STDERR "While deparsing $file near line $line,\n";
+ }
+ };
$self->{'curcv'} = main_cv;
$self->{'curcvlex'} = undef;
print $self->print_protos;
@{$self->{'subs_todo'}} =
sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
- print $self->indent($self->deparse(main_root, 0)), "\n"
+ print $self->indent($self->deparse_root(main_root)), "\n"
unless null main_root;
my @text;
while (scalar(@{$self->{'subs_todo'}})) {
$self->{'ambient_hints'} = $hint_bits;
}
+# This method is the inner loop, so try to keep it simple
sub deparse {
my $self = shift;
- my($op, $cx, $flags) = @_;
+ my($op, $cx) = @_;
Carp::confess("Null op in deparse") if !defined($op)
|| class($op) eq "NULL";
my $meth = "pp_" . $op->name;
- if (is_scope($op)) {
- return $self->$meth($op, $cx, $flags);
- }
return $self->$meth($op, $cx);
}
my $sv = $cv->const_sv;
if ($$sv) {
# uh-oh. inlinable sub... format it differently
- return $proto . "{ " . const($sv) . " }\n";
+ return $proto . "{ " . $self->const($sv, 0) . " }\n";
} else { # XSUB? (or just a declaration)
return "$proto;\n";
}
my $op = shift;
return $op->name eq "leave" || $op->name eq "scope"
|| $op->name eq "lineseq"
- || ($op->name eq "null" && class($op) eq "UNOP"
+ || ($op->name eq "null" && class($op) eq "UNOP"
&& (is_scope($op->first) || $op->first->name eq "enter"));
}
sub is_miniwhile { # check for one-line loop (`foo() while $y--')
my $op = shift;
- return (!null($op) and null($op->sibling)
+ return (!null($op) and null($op->sibling)
and $op->name eq "null" and class($op) eq "UNOP"
and (($op->first->name =~ /^(and|or)$/
and $op->first->first->sibling->name eq "lineseq")
));
}
+# Check if the op and its sibling are the initialization and the rest of a
+# for (..;..;..) { ... } loop
+sub is_for_loop {
+ my $op = shift;
+ # This OP might be almost anything, though it won't be a
+ # nextstate. (It's the initialization, so in the canonical case it
+ # will be an sassign.) The sibling is a lineseq whose first child
+ # is a nextstate and whose second is a leaveloop.
+ my $lseq = $op->sibling;
+ if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") {
+ if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
+ && (my $sib = $lseq->first->sibling)) {
+ return (!null($sib) && $sib->name eq "leaveloop");
+ }
+ }
+ return 0;
+}
+
sub is_scalar {
my $op = shift;
return ($op->name eq "rv2sv" or
my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
if( $our_local eq 'our' ) {
die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/;
- $text =~ s/(\w+::)+//;
+ $text =~ s/(\w+::)+//;
}
if (want_scalar($op)) {
return "$our_local $text";
sub padname_sv {
my $self = shift;
my $targ = shift;
- return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
+ return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
}
sub maybe_my {
}
}
}
- $expr .= $self->deparse($ops[$i], 0, (@ops != 1));
+ $expr .= $self->deparse($ops[$i], (@ops != 1)/2);
$expr =~ s/;\n?\z//;
push @exprs, $expr;
}
}
sub scopeop {
- my($real_block, $self, $op, $cx, $flags) = @_;
+ my($real_block, $self, $op, $cx) = @_;
my $kid;
my @kids;
for (; !null($kid); $kid = $kid->sibling) {
push @kids, $kid;
}
- if ($flags || $cx > 0) { # inside an expression, (a do {} while for lineseq)
+ if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
} else {
my $lineseq = $self->lineseq($op, @kids);
sub pp_lineseq { scopeop(0, @_); }
sub pp_leave { scopeop(1, @_); }
+# This is a special case of scopeop and lineseq, for the case of the
+# main_root. The difference is that we print the output statements as
+# soon as we get them, for the sake of impatient users.
+sub deparse_root {
+ my $self = shift;
+ my($op) = @_;
+ local(@$self{qw'curstash warnings hints'})
+ = @$self{qw'curstash warnings hints'};
+ my @kids;
+ for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
+ push @kids, $kid;
+ }
+ for (my $i = 0; $i < @kids; $i++) {
+ my $expr = "";
+ if (is_state $kids[$i]) {
+ $expr = $self->deparse($kids[$i], 0);
+ $i++;
+ if ($i > $#kids) {
+ print $self->indent($expr);
+ last;
+ }
+ }
+ if (is_for_loop($kids[$i])) {
+ $expr .= $self->for_loop($kids[$i], 0);
+ $expr .= ";\n" unless $i == $#kids;
+ print $self->indent($expr);
+ $i++;
+ next;
+ }
+ $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
+ $expr =~ s/;\n?\z//;
+ $expr .= ";";
+ print $self->indent($expr);
+ print "\n" unless $i == $#kids;
+ }
+}
+
# The BEGIN {} is used here because otherwise this code isn't executed
# when you run B::Deparse on itself.
my %globalnames;
return "$prefix$name" if $name =~ /::/;
- unless ($prefix eq '$' || $prefix eq '@' ||
+ unless ($prefix eq '$' || $prefix eq '@' || #'
$prefix eq '%' || $prefix eq '$#') {
return "$prefix$name";
}
push @text, "package $stash;\n";
$self->{'curstash'} = $stash;
}
- if ($self->{'linenums'}) {
- push @text, "\f#line " . $op->line .
- ' "' . $op->file, qq'"\n';
- }
if ($self->{'arybase'} != $op->arybase) {
push @text, '$[ = '. $op->arybase .";\n";
$self->{'hints'} = $op->private;
}
+ # This should go after of any branches that add statements, to
+ # increase the chances that it refers to the same line it did in
+ # the original program.
+ if ($self->{'linenums'}) {
+ push @text, "\f#line " . $op->line .
+ ' "' . $op->file, qq'"\n';
+ }
+
return join("", @text);
}
sub pp_stub {
my $self = shift;
my($op, $cx, $name) = @_;
- if ($cx) {
+ if ($cx >= 1) {
return "()";
}
else {
my $kid;
if ($op->flags & OPf_KIDS) {
$kid = $op->first;
- if (defined prototype("CORE::$name")
+ if (defined prototype("CORE::$name")
&& prototype("CORE::$name") =~ /^;?\*/
&& $kid->name eq "rv2gv") {
$kid = $kid->first;
return $self->maybe_parens_unop($name, $kid, $cx);
} else {
- return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
+ return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
}
}
}
}
-sub pp_scalar {
+sub pp_scalar {
my $self = shift;
my($op, $cv) = @_;
my $kid = $op->first;
sub padval {
my $self = shift;
my $targ = shift;
- return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
+ return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
}
sub pp_refgen {
push @exprs, $expr;
}
return $pre . join(", ", @exprs) . $post;
- } elsif (!null($kid->sibling) and
+ } elsif (!null($kid->sibling) and
$kid->sibling->name eq "anoncode") {
return "sub " .
$self->deparse_sub($self->padval($kid->sibling->targ));
sub pp_rcatline {
my $self = shift;
my($op) = @_;
- return "<" . $self->gv_name($op->gv) . ">";
+ return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
}
# Unary operators that can occur as pseudo-listops inside double quotes
$kid = $kid->sibling if not null $kid->sibling;
return $self->maybe_parens_unop($name, $kid, $cx);
} else {
- return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
+ return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
}
}
# Genuine `-X' filetests are exempt from the LLAFR, but not
# l?stat(); for the sake of clarity, give'em all parens
return $self->maybe_parens_unop($name, $op->first, $cx);
- } elsif (class($op) eq "SVOP") {
+ } elsif (class($op) =~ /^(SV|PAD)OP$/) {
return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
} else { # I don't think baseop filetests ever survive ck_ftst, but...
return $name;
}
}
-sub pp_lstat { ftst(@_, "lstat") }
-sub pp_stat { ftst(@_, "stat") }
-sub pp_ftrread { ftst(@_, "-R") }
+sub pp_lstat { ftst(@_, "lstat") }
+sub pp_stat { ftst(@_, "stat") }
+sub pp_ftrread { ftst(@_, "-R") }
sub pp_ftrwrite { ftst(@_, "-W") }
-sub pp_ftrexec { ftst(@_, "-X") }
-sub pp_fteread { ftst(@_, "-r") }
+sub pp_ftrexec { ftst(@_, "-X") }
+sub pp_fteread { ftst(@_, "-r") }
sub pp_ftewrite { ftst(@_, "-w") }
-sub pp_fteexec { ftst(@_, "-x") }
-sub pp_ftis { ftst(@_, "-e") }
+sub pp_fteexec { ftst(@_, "-x") }
+sub pp_ftis { ftst(@_, "-e") }
sub pp_fteowned { ftst(@_, "-O") }
sub pp_ftrowned { ftst(@_, "-o") }
-sub pp_ftzero { ftst(@_, "-z") }
-sub pp_ftsize { ftst(@_, "-s") }
-sub pp_ftmtime { ftst(@_, "-M") }
-sub pp_ftatime { ftst(@_, "-A") }
-sub pp_ftctime { ftst(@_, "-C") }
-sub pp_ftsock { ftst(@_, "-S") }
-sub pp_ftchr { ftst(@_, "-c") }
-sub pp_ftblk { ftst(@_, "-b") }
-sub pp_ftfile { ftst(@_, "-f") }
-sub pp_ftdir { ftst(@_, "-d") }
-sub pp_ftpipe { ftst(@_, "-p") }
-sub pp_ftlink { ftst(@_, "-l") }
-sub pp_ftsuid { ftst(@_, "-u") }
-sub pp_ftsgid { ftst(@_, "-g") }
-sub pp_ftsvtx { ftst(@_, "-k") }
-sub pp_fttty { ftst(@_, "-t") }
-sub pp_fttext { ftst(@_, "-T") }
+sub pp_ftzero { ftst(@_, "-z") }
+sub pp_ftsize { ftst(@_, "-s") }
+sub pp_ftmtime { ftst(@_, "-M") }
+sub pp_ftatime { ftst(@_, "-A") }
+sub pp_ftctime { ftst(@_, "-C") }
+sub pp_ftsock { ftst(@_, "-S") }
+sub pp_ftchr { ftst(@_, "-c") }
+sub pp_ftblk { ftst(@_, "-b") }
+sub pp_ftfile { ftst(@_, "-f") }
+sub pp_ftdir { ftst(@_, "-d") }
+sub pp_ftpipe { ftst(@_, "-p") }
+sub pp_ftlink { ftst(@_, "-l") }
+sub pp_ftsuid { ftst(@_, "-u") }
+sub pp_ftsgid { ftst(@_, "-g") }
+sub pp_ftsvtx { ftst(@_, "-k") }
+sub pp_fttty { ftst(@_, "-t") }
+sub pp_fttext { ftst(@_, "-T") }
sub pp_ftbinary { ftst(@_, "-B") }
sub SWAP_CHILDREN () { 1 }
my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
my $left = $op->first;
my $right = $op->first->sibling;
- if ($cx == 0 and is_scope($right) and $blockname
+ if ($cx < 1 and is_scope($right) and $blockname
and $self->{'expand'} < 7)
{ # if ($a) {$b}
$left = $self->deparse($left, 1);
$right = $self->deparse($right, 0);
return "$blockname ($left) {\n\t$right\n\b}\cK";
- } elsif ($cx == 0 and $blockname and not $self->{'parens'}
+ } elsif ($cx < 1 and $blockname and not $self->{'parens'}
and $self->{'expand'} < 7) { # $b if $a
$right = $self->deparse($right, 1);
$left = $self->deparse($left, 1);
} else { # $a and $b
$left = $self->deparse_binop_left($op, $left, $lowprec);
$right = $self->deparse_binop_right($op, $right, $lowprec);
- return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
+ return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
}
}
my($op, $cx) = @_;
my $text = $self->dq($op->first->sibling); # skip pushmark
if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
- or $text =~ /[<>]/) {
+ or $text =~ /[<>]/) {
return 'glob(' . single_delim('qq', '"', $text) . ')';
} else {
return '<' . $text . '>';
$indir = $indir->first; # skip rv2gv
if (is_scope($indir)) {
$indir = "{" . $self->deparse($indir, 0) . "}";
+ $indir = "{;}" if $indir eq "{}";
} elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
$indir = $self->const_sv($indir)->PV;
} else {
$expr = $self->deparse($kid, 6);
push @exprs, $expr;
}
- return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
- $cx, 5);
+ my $args = $indir . join(", ", @exprs);
+ if ($indir ne "" and $name eq "sort") {
+ # We don't want to say "sort(f 1, 2, 3)", since perl -w will
+ # give bareword warnings in that case. Therefore if context
+ # requires, we'll put parens around the outside "(sort f 1, 2,
+ # 3)". Unfortunately, we'll currently think the parens are
+ # neccessary more often that they really are, because we don't
+ # distinguish which side of an assignment we're on.
+ if ($cx >= 5) {
+ return "($name $args)";
+ } else {
+ return "$name $args";
+ }
+ } else {
+ return $self->maybe_parens_func($name, $args, $cx, 5);
+ }
+
}
sub pp_prtf { indirop(@_, "printf") }
return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
}
-sub pp_mapwhile { mapop(@_, "map") }
-sub pp_grepwhile { mapop(@_, "grep") }
+sub pp_mapwhile { mapop(@_, "map") }
+sub pp_grepwhile { mapop(@_, "grep") }
sub pp_list {
my $self = shift;
my $true = $cond->sibling;
my $false = $true->sibling;
my $cuddle = $self->{'cuddle'};
- unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
+ unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
(is_scope($false) || is_ifelse_cont($false))
and $self->{'expand'} < 7) {
$cond = $self->deparse($cond, 8);
}
$cond = $self->deparse($cond, 1);
- $true = $self->deparse($true, 0);
+ $true = $self->deparse($true, 0);
my $head = "if ($cond) {\n\t$true\n\b}";
my @elsifs;
while (!null($false) and is_ifelse_cont($false)) {
$newtrue = $self->deparse($newtrue, 0);
push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
}
- if (!null($false)) {
+ if (!null($false)) {
$false = $cuddle . "else {\n\t" .
$self->deparse($false, 0) . "\n\b}\cK";
} else {
$false = "\cK";
}
- return $head . join($cuddle, "", @elsifs) . $false;
+ return $head . join($cuddle, "", @elsifs) . $false;
}
sub loop_common {
my $bare = 0;
my $body;
my $cond = undef;
- if ($kid->name eq "lineseq") { # bare or infinite loop
+ if ($kid->name eq "lineseq") { # bare or infinite loop
if ($kid->last->name eq "unstack") { # infinite
$head = "while (1) "; # Can't use for(;;) if there's a continue
$cond = "";
sub pp_null {
my $self = shift;
- my($op, $cx, $flags) = @_;
+ my($op, $cx) = @_;
if (class($op) eq "OP") {
# old value is lost
return $self->{'ex_const'} if $op->targ == OP_CONST;
return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
. $self->deparse($op->first->sibling, 20),
$cx, 20);
- } elsif ($op->flags & OPf_SPECIAL && $cx == 0 && !$op->targ) {
- if ($flags) {
- return $self->deparse($op->first, $cx);
- }
- else {
- return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
- }
+ } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
+ 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
my $self = shift;
my($op, $cx) = @_;
return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
-}
+}
sub gv_or_padgv {
my $self = shift;
return 'XXX';
}
my $kid = $op->first;
- my $str = $self->deparse($kid, 0);
- return $self->stash_variable($type, $str) if is_scalar($kid);
- return $type ."{$str}";
+ if ($kid->name eq "gv") {
+ return $self->stash_variable($type, $self->deparse($kid, 0));
+ } elsif (is_scalar $kid) {
+ my $str = $self->deparse($kid, 0);
+ if ($str =~ /^\$([^\w\d])\z/) {
+ # "$$+" isn't a legal way to write the scalar dereference
+ # of $+, since the lexer can't tell you aren't trying to
+ # do something like "$$ + 1" to get one more than your
+ # PID. Either "${$+}" or "$${+}" are workable
+ # disambiguations, but if the programmer did the former,
+ # they'd be in the "else" clause below rather than here.
+ # It's not clear if this should somehow be unified with
+ # the code in dq and re_dq that also adds lexer
+ # disambiguation braces.
+ $str = '$' . "{$1}"; #'
+ }
+ return $type . $str;
+ } else {
+ return $type . "{" . $self->deparse($kid, 0) . "}";
+ }
}
sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
}
}
+sub list_const {
+ my $self = shift;
+ my($cx, @list) = @_;
+ my @a = map $self->const($_, 6), @list;
+ if (@a == 0) {
+ return "()";
+ } elsif (@a == 1) {
+ return $a[0];
+ } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
+ # collapse (-1,0,1,2) into (-1..2)
+ my ($s, $e) = @a[0,-1];
+ my $i = $s;
+ return $self->maybe_parens("$s..$e", $cx, 9)
+ unless grep $i++ != $_, @a;
+ }
+ return $self->maybe_parens(join(", ", @a), $cx, 6);
+}
+
sub pp_rv2av {
my $self = shift;
my($op, $cx) = @_;
my $kid = $op->first;
if ($kid->name eq "const") { # constant list
my $av = $self->const_sv($kid);
- my @a = map const($_), $av->ARRAY;
- if ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
- # collapse (-1,0,1,2) into (-1..2)
- my ($s, $e) = @a[0,-1];
- my $i = $s;
- return "($s..$e)" unless grep $i++ != $_, @a;
- }
- return "(" . join(", ", @a) . ")";
+ return $self->list_const($cx, $av->ARRAY);
} else {
return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
}
# doesn't apply), but they make a list with OPf_PARENS set that
# doesn't get flattened by the append_elem that adds the method,
# making a (object, arg1, arg2, ...) list where the object
- # usually is. This can be distinguished from
+ # usually is. This can be distinguished from
# `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
# object) because in the later the list is in scalar context
# as the left side of -> always is, while in the former
no strict 'refs';
no warnings 'uninitialized';
$declared = exists $self->{'subs_declared'}{$kid}
- || (
+ || (
defined &{ %{$self->{'curstash'}."::"}->{$kid} }
&& !exists
$self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
# it back.
$kid =~ s/^CORE::GLOBAL:://;
+ my $dproto = defined($proto) ? $proto : "undefined";
if (!$declared) {
return "$kid(" . $args . ")";
- } elsif (defined $proto and $proto eq "") {
+ } elsif ($dproto eq "") {
return $kid;
- } elsif (defined $proto and $proto eq "\$" and is_scalar($exprs[0])) {
+ } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
+ # is_scalar is an excessively conservative test here:
+ # really, we should be comparing to the precedence of the
+ # top operator of $exprs[0] (ala unop()), but that would
+ # take some major code restructuring to do right.
return $self->maybe_parens_func($kid, $args, $cx, 16);
- } elsif (defined($proto) && $proto or $simple) {
+ } elsif ($dproto ne '$' and defined($proto) || $simple) { #'
return $self->maybe_parens_func($kid, $args, $cx, 5);
} else {
return "$kid(" . $args . ")";
my($str) = @_;
$str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
$str =~ s/\a/\\a/g;
-# $str =~ s/\cH/\\b/g; # \b means something 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;
}
}
+my $max_prec;
+BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
+
+# Split a floating point number into an integer mantissa and a binary
+# exponent. Assumes you've already made sure the number isn't zero or
+# some weird infinity or NaN.
+sub split_float {
+ my($f) = @_;
+ my $exponent = 0;
+ if ($f == int($f)) {
+ while ($f % 2 == 0) {
+ $f /= 2;
+ $exponent++;
+ }
+ } else {
+ while ($f != int($f)) {
+ $f *= 2;
+ $exponent--;
+ }
+ }
+ my $mantissa = sprintf("%.0f", $f);
+ return ($mantissa, $exponent);
+}
+
sub const {
- my $sv = shift;
+ my $self = shift;
+ my($sv, $cx) = @_;
+ if ($self->{'use_dumper'}) {
+ return $self->const_dumper($sv, $cx);
+ }
if (class($sv) eq "SPECIAL") {
- return ('undef', '1', '(!1)')[$$sv-1]; # sv_undef, sv_yes, sv_no
+ # sv_undef, sv_yes, sv_no
+ return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1];
} elsif (class($sv) eq "NULL") {
return 'undef';
}
}
if ($sv->FLAGS & SVf_IOK) {
- return $sv->int_value;
+ my $str = $sv->int_value;
+ $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
+ return $str;
} elsif ($sv->FLAGS & SVf_NOK) {
- # try the default stringification
- my $r = "".$sv->NV;
- if ($r =~ /e/) {
- # If it's in scientific notation, we might have lost information
- return sprintf("%.20e", $sv->NV);
+ my $nv = $sv->NV;
+ if ($nv == 0) {
+ if (pack("F", $nv) eq pack("F", 0)) {
+ # positive zero
+ return "0";
+ } else {
+ # negative zero
+ return $self->maybe_parens("-.0", $cx, 21);
+ }
+ } elsif (1/$nv == 0) {
+ if ($nv > 0) {
+ # positive infinity
+ return $self->maybe_parens("9**9**9", $cx, 22);
+ } else {
+ # negative infinity
+ return $self->maybe_parens("-9**9**9", $cx, 21);
+ }
+ } elsif ($nv != $nv) {
+ # NaN
+ if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
+ # the normal kind
+ return "sin(9**9**9)";
+ } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
+ # the inverted kind
+ return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
+ } else {
+ # some other kind
+ my $hex = unpack("h*", pack("F", $nv));
+ return qq'unpack("F", pack("h*", "$hex"))';
+ }
}
- return $r;
+ # first, try the default stringification
+ my $str = "$nv";
+ if ($str != $nv) {
+ # failing that, try using more precision
+ $str = sprintf("%.${max_prec}g", $nv);
+# if (pack("F", $str) ne pack("F", $nv)) {
+ if ($str != $nv) {
+ # not representable in decimal with whatever sprintf()
+ # and atof() Perl is using here.
+ my($mant, $exp) = split_float($nv);
+ return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
+ }
+ }
+ $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
+ return $str;
} elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
- return "\\(" . const($sv->RV) . ")"; # constant folded
+ my $ref = $sv->RV;
+ if (class($ref) eq "AV") {
+ return "[" . $self->list_const(2, $ref->ARRAY) . "]";
+ } elsif (class($ref) eq "HV") {
+ my %hash = $ref->ARRAY;
+ my @elts;
+ for my $k (sort keys %hash) {
+ push @elts, "$k => " . $self->const($hash{$k}, 6);
+ }
+ return "{" . join(", ", @elts) . "}";
+ } elsif (class($ref) eq "CV") {
+ return "sub " . $self->deparse_sub($ref);
+ }
+ if ($ref->FLAGS & SVs_SMG) {
+ for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
+ if ($mg->TYPE eq 'r') {
+ my $re = re_uninterp(escape_str(re_unback($mg->precomp)));
+ return single_delim("qr", "", $re);
+ }
+ }
+ }
+
+ return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20);
} elsif ($sv->FLAGS & SVf_POK) {
my $str = $sv->PV;
if ($str =~ /[^ -~]/) { # ASCII for non-printing
}
}
+sub const_dumper {
+ my $self = shift;
+ my($sv, $cx) = @_;
+ my $ref = $sv->object_2svref();
+ my $dumper = Data::Dumper->new([$$ref], ['$v']);
+ $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
+ my $str = $dumper->Dump();
+ if ($str =~ /^\$v/) {
+ return '${my ' . $str . ' \$v}';
+ } else {
+ return $str;
+ }
+}
+
sub const_sv {
my $self = shift;
my $op = shift;
if ($op->private & OPpCONST_ARYBASE) {
return '$[';
}
-# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
+# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
# return $self->const_sv($op)->PV;
# }
my $sv = $self->const_sv($op);
-# return const($sv);
- my $c = const $sv;
- return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
+ return $self->const($sv, $cx);
}
sub dq {
# Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
($last =~ /^[A-Z\\\^\[\]_?]/ &&
$first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
- || ($last =~ /^[:'{\[\w_]/ &&
+ || ($last =~ /^[:'{\[\w_]/ && #'
$first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
return $first . $last;
my(@table) = unpack("s*", $table);
splice @table, 0x100, 1; # Number of subsequent elements
my($c, $tr, @from, @to, @delfrom, $delhyphen);
- if ($table[ord "-"] != -1 and
+ if ($table[ord "-"] != -1 and
$table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
{
$tr = $table[ord "-"];
}
$result = hex $result;
if ($result == $extra) {
- push @delfrom, [$min, $max];
+ push @delfrom, [$min, $max];
} else {
push @from, [$min, $max];
push @to, [$result, $result + $max - $min];
}
#$final = sprintf("%04x", $final) if defined $final;
#$none = sprintf("%04x", $none) if defined $none;
- #$extra = sprintf("%04x", $extra) if defined $extra;
+ #$extra = sprintf("%04x", $extra) if defined $extra;
#print STDERR "final: $final\n none: $none\nextra: $extra\n";
#print STDERR $swash{'LIST'}->PV;
return (escape_str($from), escape_str($to));
return $self->pure_string($op->first)
&& $self->pure_string($op->last);
}
- elsif (is_scalar($op) || $type =~ /^[ah]elem(fast)?$/) {
+ elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
+ return 1;
+ }
+ elsif ($type eq "null" and not null $op->first and
+ $op->first->name eq "null" and not null $op->first->first and
+ $op->first->first->name eq "aelemfast") {
return 1;
}
else {
my %matchwords;
map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
- 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
- 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
+ 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
+ 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
sub matchop {
my $self = shift;
} elsif ($kid->name ne 'regcomp') {
carp("found ".$kid->name." where regcomp expected");
} else {
- ($re, $quote) = $self->regcomp($kid, 1, $extended);
+ ($re, $quote) = $self->regcomp($kid, 21, $extended);
}
my $flags = "";
$flags .= "c" if $op->pmflags & PMf_CONTINUE;
$var = $self->deparse($kid, 20);
$kid = $kid->sibling;
}
- my $flags = "";
+ my $flags = "";
if (null($op->pmreplroot)) {
$repl = $self->dq($kid);
$kid = $kid->sibling;
$flags .= "e";
}
if ($op->pmflags & PMf_EVAL) {
- $repl = $self->deparse($repl, 0, 1);
+ $repl = $self->deparse($repl->first, 0);
} else {
$repl = $self->dq($repl);
}
=head1 SYNOPSIS
-B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
+B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
[B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
=head1 DESCRIPTION
required by precedence, which can make it easy to see if perl is
parsing your expressions the way you intended.
-Please note that this module is mainly new and untested code and is
-still under development, so it may change in the future.
+While B::Deparse goes to some lengths to try to figure out what your
+original program was doing, some parts of the language can still trip
+it up; it still fails even on some parts of Perl's own test suite. If
+you encounter a failure other than the most common ones described in
+the BUGS section below, you can help contribute to B::Deparse's
+ongoing development by submitting a bug report with a small
+example.
=head1 OPTIONS
=over 4
+=item B<-d>
+
+Output data values (when they appear as constants) using Data::Dumper.
+Without this option, B::Deparse will use some simple routines of its
+own for the same purpose. Currently, Data::Dumper is better for some
+kinds of data (such as complex structures with sharing and
+self-reference) while the built-in routines are better for others
+(such as odd floating-point values).
+
+=item B<-f>I<FILE>
+
+Normally, B::Deparse deparses the main code of a program, and all the subs
+defined in the same file. To include subs defined in other files, pass the
+B<-f> option with the filename. You can pass the B<-f> option several times, to
+include more than one secondary file. (Most of the time you don't want to
+use it at all.) You can also use this option to include subs which are
+defined in the scope of a B<#line> directive with two parameters.
+
=item B<-l>
Add '#line' declarations to the output based on the line and file
whenever they would be legal. This can be useful if you are used to
LISP, or if you want to see how perl parses your input. If you say
- if ($var & 0x7f == 65) {print "Gimme an A!"}
+ if ($var & 0x7f == 65) {print "Gimme an A!"}
print ($which ? $a : $b), "\n";
$name = $ENV{USER} or "Bob";
C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
of $y into a string before doing the assignment.
-=item B<-f>I<FILE>
-
-Normally, B::Deparse deparses the main code of a program, and all the subs
-defined in the same file. To include subs defined in other files, pass the
-B<-f> option with the filename. You can pass the B<-f> option several times, to
-include more than one secondary file. (Most of the time you don't want to
-use it at all.) You can also use this option to include subs which are
-defined in the scope of a B<#line> directive with two parameters.
-
=item B<-s>I<LETTERS>
Tweak the style of B::Deparse's output. The letters should follow
meaning more expansion. As with B<-q>, this actually involves turning off
special cases in B::Deparse's normal operations.
-If I<LEVEL> is at least 3, for loops will be translated into equivalent
+If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
while loops with continue blocks; for instance
for ($i = 0; $i < 10; ++$i) {
into the source code -- if the loop's initializer declares a my variable,
for instance, it won't have the correct scope outside of the loop.
-If I<LEVEL> is at least 7, if statements will be translated into equivalent
-expressions using C<&&>, C<?:> and C<do {}>; for instance
+If I<LEVEL> is at least 5, C<use> declarations will be translated into
+C<BEGIN> blocks containing calls to C<require> and C<import>; for
+instance,
+
+ use strict 'refs';
+
+turns into
+
+ sub BEGIN {
+ require strict;
+ do {
+ 'strict'->import('refs')
+ };
+ }
+
+If I<LEVEL> is at least 7, C<if> statements will be translated into
+equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
print 'hi' if $nice;
if ($nice) {
Ordinarily, if you use B::Deparse on a subroutine which has
been compiled in the presence of one or more of these pragmas,
the output will include statements to turn on the appropriate
-directives. So if you then compile the code returned by coderef2text,
+directives. So if you then compile the code returned by coderef2text,
it will behave the same way as the subroutine which you deparsed.
However, you may know that you intend to use the results in a
warnings => [FATAL => qw/void io/],
);
-See L<perllexwarn> for more information about lexical warnings.
+See L<perllexwarn> for more information about lexical warnings.
=item hint_bits
Excepting those listed above, we're currently unable to guarantee that
B::Deparse will produce a pragma at the correct point in the program.
+(Specifically, pragmas at the beginning of a block often appear right
+before the start of the block instead.)
Since the effects of pragmas are often lexically scoped, this can mean
that the pragma holds sway over a different portion of the program
than in the input file.
(such as by over-riding keywords, overloading constants or whatever)
then the output code might not work as intended.
-This is the most serious outstanding problem, and will be very hard
-to fix.
+This is the most serious outstanding problem, and will require some help
+from the Perl core to fix.
=item *
=item *
-C<sort foo (1, 2, 3)> comes out as C<sort (foo 1, 2, 3)>, which
-causes perl to issue a warning.
-
-The obvious fix doesn't work, because these are different:
-
- print (FOO 1, 2, 3), 4, 5, 6;
- print FOO (1, 2, 3), 4, 5, 6;
-
-=item *
-
-Constants (other than simple strings or numbers) don't work properly.
-Pathological examples that fail (and probably always will) include:
-
- use constant E2BIG => ($!=7);
- use constant x=>\$x; print x
-
-The following could (and should) be made to work:
+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:
- use constant regex => qr/blah/;
- print regex;
+ use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
=item *
=head1 AUTHOR
-Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
-version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
-contributions from Gisle Aas, James Duncan, Albert Dvornik, Robin
-Houston, Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons,
-and Rafael Garcia-Suarez.
+Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version
+by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from
+Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
+Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael
+Garcia-Suarez.
=cut
projects / p5sagit/p5-mst-13.2.git / commitdiff