# B::Deparse.pm
-# Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved.
+# Copyright (c) 1998-2000, 2002, 2003, 2004, 2005, 2006 Stephen McCamant.
+# All rights reserved.
# This module is free software; you can redistribute and/or modify
# it under the same terms as Perl itself.
package B::Deparse;
use Carp;
-use B qw(class main_root main_start main_cv svref_2object opnumber cstring
+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
+ OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPpPAD_STATE
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
- CVf_METHOD CVf_LOCKED CVf_LVALUE
+ OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED
+ 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.62;
+$VERSION = 0.79;
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
# - 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.)
+# 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
+#
+# ...
+#
+# Changes between 0.72 and 0.73
+# - support new switch constructs
# 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;
}
my $file = $gv->FILE;
$l = "\n\f#line $line \"$file\"\n";
}
- return "${l}sub $name " . $self->deparse_sub($cv);
+ my $p = '';
+ if (class($cv->STASH) ne "SPECIAL") {
+ my $stash = $cv->STASH->NAME;
+ if ($stash ne $self->{'curstash'}) {
+ $p = "package $stash;\n";
+ $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
+ $self->{'curstash'} = $stash;
+ }
+ $name =~ s/^\Q$stash\E:://;
+ }
+ return "${p}${l}sub $name " . $self->deparse_sub($cv);
}
}
$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)->int_value;
+ $version = $self->const_sv($constop);
+ 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
+ $version = 'v'.join '.', map ord, split //, $version->PV;
+ }
$constop = $constop->sibling;
return if $constop->name ne "method_named";
return if $self->const_sv($constop)->PV ne "VERSION";
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") {
$self->{'warnings'} = defined ($self->{'ambient_warnings'})
? $self->{'ambient_warnings'} & WARN_MASK
: undef;
- $self->{'hints'} = $self->{'ambient_hints'} & 0xFF;
+ $self->{'hints'} = $self->{'ambient_hints'};
# also a convenient place to clear out subs_declared
delete $self->{'subs_declared'};
sub compile {
my(@args) = @_;
- return sub {
+ return sub {
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 @UNITCHECKs = B::unitcheck_av->isa("B::AV")
+ ? B::unitcheck_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, @UNITCHECKs, @CHECKs, @INITs, @ENDs) {
$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'}})) {
my $laststash = defined $self->{'curcop'}
? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
if (defined *{$laststash."::DATA"}{IO}) {
+ print "package $laststash;\n"
+ unless $laststash eq $self->{'curstash'};
print "__DATA__\n";
print readline(*{$laststash."::DATA"});
}
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)));
$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);
}
if ($cv->FLAGS & SVf_POK) {
$proto = "(". $cv->PV . ") ";
}
- if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
+ if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ASSERTION)) {
$proto .= ": ";
$proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
$proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
$proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
+ $proto .= "assertion " if $cv->CvFLAGS & CVf_ASSERTION;
}
local($self->{'curcv'}) = $cv;
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
if ($op->private & (OPpLVAL_INTRO|$our_intro)
and not $self->{'avoid_local'}{$$op}) {
my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
+ if( $our_local eq 'our' ) {
+ # XXX This assertion fails code with non-ASCII identifiers,
+ # like ./ext/Encode/t/jperl.t
+ die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/;
+ $text =~ s/(\w+::)+//;
+ }
if (want_scalar($op)) {
return "$our_local $text";
} else {
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 {
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";
if (want_scalar($op)) {
- return "my $text";
+ return "$my $text";
} else {
- return $self->maybe_parens_func("my", $text, $cx, 16);
+ return $self->maybe_parens_func($my, $text, $cx, 16);
}
} else {
return $text;
}
}
+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
# any subroutine declarations to the deparsed ops, otherwise we
my $limit_seq;
if (defined $root) {
$limit_seq = $out_seq;
- my $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
+ my $nseq;
+ $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
$limit_seq = $nseq if !defined($limit_seq)
or defined($nseq) && $nseq < $limit_seq;
}
}
}
}
- $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;
+ return if null $op->first; # Can happen, e.g., for Bytecode without -k
+ 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;
sub gv_name {
my $self = shift;
my $gv = shift;
-Carp::confess() if $gv->isa("B::CV");
+Carp::confess() unless ref($gv) eq "B::GV";
my $stash = $gv->STASH->NAME;
my $name = $gv->SAFENAME;
- if ($stash eq $self->{'curstash'} or $globalnames{$name}
- or $name =~ /^[^A-Za-z_]/)
+ if (($stash eq 'main' && $globalnames{$name})
+ or ($stash eq $self->{'curstash'} && !$globalnames{$name})
+ or $name =~ /^[^A-Za-z_:]/)
{
$stash = "";
} else {
return "$prefix$name" if $name =~ /::/;
- unless ($prefix eq '$' || $prefix eq '@' ||
+ unless ($prefix eq '$' || $prefix eq '@' || #'
$prefix eq '%' || $prefix eq '$#') {
return "$prefix$name";
}
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) {
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];
}
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->{'warnings'} = $warning_bits;
}
- if ($self->{'hints'} != $op->private) {
- push @text, declare_hints($self->{'hints'}, $op->private);
- $self->{'hints'} = $op->private;
+ if ($self->{'hints'} != $op->hints) {
+ push @text, declare_hints($self->{'hints'}, $op->hints);
+ $self->{'hints'} = $op->hints;
+ }
+
+ # 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 declare_warnings {
my ($from, $to) = @_;
- if (($to & WARN_MASK) eq warnings::bits("all")) {
+ if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
return "use warnings;\n";
}
- elsif (($to & WARN_MASK) eq "\0"x length($to)) {
+ elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
return "no warnings;\n";
}
- return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n";
+ return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n";
}
sub declare_hints {
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_lock { unop(@_, "lock") }
+sub pp_continue { unop(@_, "continue"); }
+sub pp_break {
+ my ($self, $op) = @_;
+ return "" if $op->flags & OPf_SPECIAL;
+ unop(@_, "break");
+}
+
+sub givwhen {
+ my $self = shift;
+ my($op, $cx, $givwhen) = @_;
+
+ my $enterop = $op->first;
+ my ($head, $block);
+ if ($enterop->flags & OPf_SPECIAL) {
+ $head = "default";
+ $block = $self->deparse($enterop->first, 0);
+ }
+ else {
+ my $cond = $enterop->first;
+ my $cond_str = $self->deparse($cond, 1);
+ $head = "$givwhen ($cond_str)";
+ $block = $self->deparse($cond->sibling, 0);
+ }
+
+ return "$head {\n".
+ "\t$block\n".
+ "\b}\cK";
+}
+
+sub pp_leavegiven { givwhen(@_, "given"); }
+sub pp_leavewhen { givwhen(@_, "when"); }
+
sub pp_exists {
my $self = shift;
my($op, $cx) = @_;
sub pp_require {
my $self = shift;
my($op, $cx) = @_;
+ my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
if (class($op) eq "UNOP" and $op->first->name eq "const"
and $op->first->private & OPpCONST_BARE)
{
my $name = $self->const_sv($op->first)->PV;
$name =~ s[/][::]g;
$name =~ s/\.pm//g;
- return "require $name";
+ return "$opname $name";
} else {
- $self->unop($op, $cx, "require");
+ $self->unop($op, $cx, $opname);
}
}
-sub pp_scalar {
+sub pp_scalar {
my $self = shift;
- my($op, $cv) = @_;
+ my($op, $cx) = @_;
my $kid = $op->first;
if (not null $kid->sibling) {
# XXX Was a here-doc
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 anon_hash_or_list {
+ my $self = shift;
+ my($op, $cx) = @_;
+
+ my($pre, $post) = @{{"anonlist" => ["[","]"],
+ "anonhash" => ["{","}"]}->{$op->name}};
+ my($expr, @exprs);
+ $op = $op->first->sibling; # skip pushmark
+ for (; !null($op); $op = $op->sibling) {
+ $expr = $self->deparse($op, 6);
+ push @exprs, $expr;
+ }
+ if ($pre eq "{" and $cx < 1) {
+ # Disambiguate that it's not a block
+ $pre = "+{";
+ }
+ return $pre . join(", ", @exprs) . $post;
+}
+
+sub pp_anonlist {
+ my $self = shift;
+ my ($op, $cx) = @_;
+ if ($op->flags & OPf_SPECIAL) {
+ return $self->anon_hash_or_list($op, $cx);
+ }
+ warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL";
+ return 'XXX';
+}
+
+*pp_anonhash = \&pp_anonlist;
+
sub pp_refgen {
my $self = shift;
my($op, $cx) = @_;
if ($kid->name eq "null") {
$kid = $kid->first;
if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
- my($pre, $post) = @{{"anonlist" => ["[","]"],
- "anonhash" => ["{","}"]}->{$kid->name}};
- my($expr, @exprs);
- $kid = $kid->first->sibling; # skip pushmark
- for (; !null($kid); $kid = $kid->sibling) {
- $expr = $self->deparse($kid, 6);
- push @exprs, $expr;
- }
- return $pre . join(", ", @exprs) . $post;
- } elsif (!null($kid->sibling) and
+ return $self->anon_hash_or_list($op, $cx);
+ } elsif (!null($kid->sibling) and
$kid->sibling->name eq "anoncode") {
return "sub " .
$self->deparse_sub($self->padval($kid->sibling->targ));
{
# The @a in \(@a) isn't in ref context, but only when the
# parens are there.
- return "\\(" . $self->deparse($kid->sibling, 1) . ")";
+ return "\\(" . $self->pp_list($op->first) . ")";
} elsif ($sib_name eq 'entersub') {
my $text = $self->deparse($kid->sibling, 1);
# Always show parens for \(&func()), but only with -p otherwise
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 }
sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
+sub pp_smartmatch {
+ my ($self, $op, $cx) = @_;
+ if ($op->flags & OPf_SPECIAL) {
+ return $self->deparse($op->first, $cx);
+ }
+ else {
+ binop(@_, "~~", 14);
+ }
+}
+
# `.' is special because concats-of-concats are optimized to save copying
# by making all but the first concat stacked. The effect is as if the
# programmer had written `($a . $b) .= $c', except legal.
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);
}
}
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.
}
sub pp_andassign { logassignop(@_, "&&=") }
-sub pp_orassign { logassignop(@_, "||=") }
+sub pp_orassign { logassignop(@_, "||=") }
+sub pp_dorassign { logassignop(@_, "//=") }
sub listop {
my $self = shift;
return $name if null $kid;
my $first;
$name = "socketpair" if $name eq "sockpair";
- if (defined prototype("CORE::$name")
- && prototype("CORE::$name") =~ /^;?\*/
+ my $proto = prototype("CORE::$name");
+ if (defined $proto
+ && $proto =~ /^;?\*/
&& $kid->name eq "rv2gv") {
$first = $self->deparse($kid->first, 6);
}
$first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
push @exprs, $first;
$kid = $kid->sibling;
+ if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") {
+ push @exprs, $self->deparse($kid->first, 6);
+ $kid = $kid->sibling;
+ }
for (; !null($kid); $kid = $kid->sibling) {
push @exprs, $self->deparse($kid, 6);
}
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 {
$kid = $kid->sibling;
}
if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
- $indir = ($op->private & OPpSORT_REVERSE) ? '{$b <=> $a} '
+ $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
: '{$a <=> $b} ';
}
- elsif ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
+ elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
$indir = '{$b cmp $a} ';
}
for (; !null($kid); $kid = $kid->sibling) {
$expr = $self->deparse($kid, 6);
push @exprs, $expr;
}
- return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
- $cx, 5);
+ my $name2 = $name;
+ if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
+ $name2 = 'reverse sort';
+ }
+ if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
+ return "$exprs[0] = $name2 $indir $exprs[0]";
+ }
+
+ 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
+ # necessary more often that they really are, because we don't
+ # distinguish which side of an assignment we're on.
+ if ($cx >= 5) {
+ return "($name2 $args)";
+ } else {
+ return "$name2 $args";
+ }
+ } else {
+ return $self->maybe_parens_func($name2, $args, $cx, 5);
+ }
+
}
sub pp_prtf { indirop(@_, "printf") }
$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);
}
-sub pp_mapwhile { mapop(@_, "map") }
-sub pp_grepwhile { mapop(@_, "grep") }
+sub pp_mapwhile { mapop(@_, "map") }
+sub pp_grepwhile { mapop(@_, "grep") }
+sub pp_mapstart { baseop(@_, "map") }
+sub pp_grepstart { baseop(@_, "grep") }
sub pp_list {
my $self = shift;
my($expr, @exprs);
my $kid = $op->first->sibling; # skip pushmark
my $lop;
- my $local = "either"; # could be local(...), my(...) or our(...)
+ my $local = "either"; # could be local(...), my(...), state(...) or our(...)
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,
$local = ""; # or not
last;
}
- if ($lop->name =~ /^pad[ash]v$/) { # my()
- ($local = "", last) if $local eq "local" || $local eq "our";
- $local = "my";
+ if ($lop->name =~ /^pad[ash]v$/) {
+ if ($lop->private & OPpPAD_STATE) { # state()
+ ($local = "", last) if $local =~ /^(?:local|our|my)$/;
+ $local = "state";
+ } else { # my()
+ ($local = "", last) if $local =~ /^(?:local|our|state)$/;
+ $local = "my";
+ }
} elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
&& $lop->private & OPpOUR_INTRO
or $lop->name eq "null" && $lop->first->name eq "gvsv"
&& $lop->first->private & OPpOUR_INTRO) { # our()
- ($local = "", last) if $local eq "my" || $local eq "local";
+ ($local = "", last) if $local =~ /^(?:my|local|state)$/;
$local = "our";
- } elsif ($lop->name ne "undef") { # local()
- ($local = "", last) if $local eq "my" || $local eq "our";
+ } elsif ($lop->name ne "undef"
+ # specifically avoid the "reverse sort" optimisation,
+ # where "reverse" is nullified
+ && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
+ {
+ # local()
+ ($local = "", last) if $local =~ /^(?:my|our|state)$/;
$local = "local";
}
}
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);
- $true = $self->deparse($true, 8);
+ $true = $self->deparse($true, 6);
$false = $self->deparse($false, 8);
return $self->maybe_parens("$cond ? $true : $false", $cx, 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 (is_state $kid->last) { # infinite
+ 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 = "";
} else {
} elsif ($enter->name eq "enteriter") { # foreach
my $ary = $enter->first->sibling; # first was pushmark
my $var = $ary->sibling;
- if ($enter->flags & OPf_STACKED
+ if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
+ # "reverse" was optimised away
+ $ary = listop($self, $ary->first->sibling, 1, 'reverse');
+ } elsif ($enter->flags & OPf_STACKED
and not null $ary->first->sibling->sibling)
{
$ary = $self->deparse($ary->first->sibling, 9) . " .. " .
$var = $self->pp_threadsv($enter, 1);
} else { # regular my() variable
$var = $self->pp_padsv($enter, 1);
- if ($self->padname_sv($enter->targ)->IVX ==
- $kid->first->first->sibling->last->cop_seq)
- {
- # If the scope of this variable closes at the last
- # statement of the loop, it must have been
- # declared here.
- $var = "my " . $var;
- }
}
} elsif ($var->name eq "rv2gv") {
$var = $self->pp_rv2sv($var, 1);
+ if ($enter->private & OPpOUR_INTRO) {
+ # our declarations don't have package names
+ $var =~ s/^(.).*::/$1/;
+ $var = "our $var";
+ }
} elsif ($var->name eq "gv") {
$var = "\$" . $self->deparse($var, 1);
}
- $head = "foreach $var ($ary) ";
$body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
+ if (!is_state $body->first and $body->first->name ne "stub") {
+ confess unless $var eq '$_';
+ $body = $body->first;
+ return $self->deparse($body, 2) . " foreach ($ary)";
+ }
+ $head = "foreach $var ($ary) ";
} elsif ($kid->name eq "null") { # while/until
$kid = $kid->first;
my $name = {"and" => "while", "or" => "until"}->{$kid->name};
return "{;}"; # {} could be a hashref
}
# If there isn't a continue block, then the next pointer for the loop
- # will point to the unstack, which is kid's penultimate child, except
+ # will point to the unstack, which is kid's last child, except
# in a bare loop, when it will point to the leaveloop. When neither of
- # these conditions hold, then the third-to-last child in the continue
+ # these conditions hold, then the second-to-last child is the continue
# block (or the last in a bare loop).
my $cont_start = $enter->nextop;
my $cont;
- if ($$cont_start != $$op && ${$cont_start->sibling} != ${$body->last}) {
+ if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
if ($bare) {
$cont = $body->last;
} else {
$cont = $body->first;
- while (!null($cont->sibling->sibling->sibling)) {
+ while (!null($cont->sibling->sibling)) {
$cont = $cont->sibling;
}
}
return $self->pp_list($op, $cx);
} elsif ($op->first->name eq "enter") {
return $self->pp_leave($op, $cx);
+ } elsif ($op->first->name eq "leave") {
+ return $self->pp_leave($op->first, $cx);
+ } elsif ($op->first->name eq "scope") {
+ return $self->pp_scope($op->first, $cx);
} elsif ($op->targ == OP_STRINGIFY) {
return $self->dquote($op, $cx);
} elsif (!null($op->first->sibling) and
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) {
+ } 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
my $self = shift;
my($op, $cx) = @_;
return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
-}
+}
sub gv_or_padgv {
my $self = shift;
sub pp_aelemfast {
my $self = shift;
my($op, $cx) = @_;
- my $gv = $self->gv_or_padgv($op);
- my $name = $self->gv_name($gv);
- $name = $self->{'curstash'}."::$name"
- if $name !~ /::/ && $self->lex_in_scope('@'.$name);
+ 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;
+ }
- return "\$" . $name . "[" .
- ($op->private + $self->{'arybase'}) . "]";
+ return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
}
sub rv2x {
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);
- return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
+ return $self->list_const($cx, $av->ARRAY);
} else {
return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
}
}
}
-sub elem {
+sub elem_or_slice_array_name
+{
my $self = shift;
- my ($op, $cx, $left, $right, $padname) = @_;
- my($array, $idx) = ($op->first, $op->first->sibling);
- unless ($array->name eq $padname) { # Maybe this has been fixed
- $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
- }
+ my ($array, $left, $padname, $allow_arrow) = @_;
+
if ($array->name eq $padname) {
- $array = $self->padany($array);
+ return $self->padany($array);
} elsif (is_scope($array)) { # ${expr}[0]
- $array = "{" . $self->deparse($array, 0) . "}";
+ return "{" . $self->deparse($array, 0) . "}";
} elsif ($array->name eq "gv") {
$array = $self->gv_name($self->gv_or_padgv($array));
if ($array !~ /::/) {
$array = $self->{curstash}.'::'.$array
if $self->lex_in_scope($prefix . $array);
}
- } elsif (is_scalar $array) { # $x[0], $$x[0], ...
- $array = $self->deparse($array, 24);
+ return $array;
+ } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
+ return $self->deparse($array, 24);
} else {
- # $x[20][3]{hi} or expr->[20]
- my $arrow = is_subscriptable($array) ? "" : "->";
- return $self->deparse($array, 24) . $arrow .
- $left . $self->deparse($idx, 1) . $right;
+ return undef;
}
+}
+
+sub elem_or_slice_single_index
+{
+ my $self = shift;
+ my ($idx) = @_;
+
$idx = $self->deparse($idx, 1);
# Outer parens in an array index will confuse perl
#
$idx =~ s/^([A-Za-z_]\w*)$/$1()/;
- return "\$" . $array . $left . $idx . $right;
+ return $idx;
+}
+
+sub elem {
+ my $self = shift;
+ my ($op, $cx, $left, $right, $padname) = @_;
+ my($array, $idx) = ($op->first, $op->first->sibling);
+
+ $idx = $self->elem_or_slice_single_index($idx);
+
+ unless ($array->name eq $padname) { # Maybe this has been fixed
+ $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
+ }
+ if (my $array_name=$self->elem_or_slice_array_name
+ ($array, $left, $padname, 1)) {
+ return "\$" . $array_name . $left . $idx . $right;
+ } else {
+ # $x[20][3]{hi} or expr->[20]
+ my $arrow = is_subscriptable($array) ? "" : "->";
+ return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
+ }
+
}
sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
$array = $last;
$array = $array->first
if $array->name eq $regname or $array->name eq "null";
- if (is_scope($array)) {
- $array = "{" . $self->deparse($array, 0) . "}";
- } elsif ($array->name eq $padname) {
- $array = $self->padany($array);
- } else {
- $array = $self->deparse($array, 24);
- }
+ $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
$kid = $op->first->sibling; # skip pushmark
if ($kid->name eq "list") {
$kid = $kid->first->sibling; # skip list, pushmark
}
$list = join(", ", @elems);
} else {
- $list = $self->deparse($kid, 1);
+ $list = $self->elem_or_slice_single_index($kid);
}
return "\@" . $array . $left . $list . $right;
}
# 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} }
+ || (
+ defined &{ ${$self->{'curstash'}."::"}{$kid} }
&& !exists
$self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
&& defined prototype $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 . ")";
| \\[uUlLQE]
)
- /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
+ /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
return $str;
}
| \#[^\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/\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;
$str =~ s/\f/\\f/g;
$str =~ s/\r/\\r/g;
- $str =~ s/([\cA-\cZ])/sprintf("\\c%c", ord('@') + ord($1))/ge;
+ $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
$str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
return $str;
}
sub balanced_delim {
my($str) = @_;
my @str = split //, $str;
- my($ar, $open, $close, $fail, $c, $cnt);
+ my($ar, $open, $close, $fail, $c, $cnt, $last_bs);
for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
($open, $close) = @$ar;
- $fail = 0; $cnt = 0;
+ $fail = 0; $cnt = 0; $last_bs = 0;
for $c (@str) {
if ($c eq $open) {
+ $fail = 1 if $last_bs;
$cnt++;
} elsif ($c eq $close) {
+ $fail = 1 if $last_bs;
$cnt--;
if ($cnt < 0) {
# qq()() isn't ")("
last;
}
}
+ $last_bs = $c eq '\\';
}
$fail = 1 if $cnt != 0;
return ($open, "$open$str$close") if not $fail;
}
}
+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', '0')[$$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';
- } elsif ($sv->FLAGS & SVf_IOK) {
- return $sv->int_value;
+ }
+ # convert a version object into the "v1.2.3" string in its V magic
+ if ($sv->FLAGS & SVs_RMG) {
+ for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
+ return $mg->PTR if $mg->TYPE eq 'V';
+ }
+ }
+
+ if ($sv->FLAGS & SVf_IOK) {
+ 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"))';
+ }
+ }
+ # 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);
+ }
}
- return $r;
+ $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
+ if ($str =~ /[[:^print:]]/) {
return single_delim("qq", '"', uninterp escape_str unback $str);
} else {
return single_delim("q", "'", unback $str);
}
}
+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 {
my $first = $self->dq($op->first);
my $last = $self->dq($op->last);
- # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
+ # 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));
sub pure_string {
my ($self, $op) = @_;
+ return 0 if null $op;
my $type = $op->name;
if ($type eq 'const') {
return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
return 0 unless ${$join_op->sibling} eq ${$op->last};
- return 0 unless $op->last->name =~ /^(rv2|pad)av$/;
+ return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
}
elsif ($type eq 'concat') {
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 $op->can('first') and not null $op->first and
+ $op->first->name eq "null" and $op->first->can('first')
+ and not null $op->first->first and
+ $op->first->first->name eq "aelemfast") {
return 1;
}
else {
my $kid = $op->first;
$kid = $kid->first if $kid->name eq "regcmaybe";
$kid = $kid->first if $kid->name eq "regcreset";
+ if ($kid->name eq "null" and !null($kid->first)
+ and $kid->first->name eq 'pushmark')
+ {
+ my $str = '';
+ $kid = $kid->first->sibling;
+ while (!null($kid)) {
+ $str .= $self->re_dq($kid, $extended);
+ $kid = $kid->sibling;
+ }
+ return $str, 1;
+ }
+
return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
return ($self->deparse($kid, $cx), 0);
}
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;
my($op, $cx) = @_;
my($kid, @exprs, $ary, $expr);
$kid = $op->first;
- # under ithreads pmreplroot is an integer, not an SV
+
+ # For our kid (an OP_PUSHRE), pmreplroot is never actually the
+ # root of a replacement; it's either empty, or abused to point to
+ # the GV for an array we split into (an optimization to save
+ # assignment overhead). Depending on whether we're using ithreads,
+ # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
+ # figures out for us which it is.
my $replroot = $kid->pmreplroot;
- if ( ( ref($replroot) && $$replroot ) ||
- ( !ref($replroot) && $replroot ) ) {
- $ary = $self->stash_variable('@', $self->gv_name($kid->pmreplroot));
+ my $gv = 0;
+ if (ref($replroot) eq "B::GV") {
+ $gv = $replroot;
+ } elsif (!ref($replroot) and $replroot > 0) {
+ $gv = $self->padval($replroot);
}
+ $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv;
+
for (; !null($kid); $kid = $kid->sibling) {
push @exprs, $self->deparse($kid, 6);
}
- # handle special case of split(), and split(" ") that compiles to /\s+/
+ # handle special case of split(), and split(' ') that compiles to /\s+/
$kid = $op->first;
- if ($kid->flags & OPf_SPECIAL
- && $exprs[0] eq '/\\s+/'
- && $kid->pmflags & PMf_SKIPWHITE ) {
- $exprs[0] = '" "';
+ if ($kid->flags & OPf_SPECIAL and $kid->pmflags & PMf_SKIPWHITE) {
+ $exprs[0] = "' '";
}
$expr = "split(" . join(", ", @exprs) . ")";
$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);
+ $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.
+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:
-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;
+ use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
=item *
-Constants (other than simple strings or numbers) don't work properly.
-Pathological examples that fail (and probably always will) include:
+An input file that uses source filtering probably won't be deparsed into
+runnable code, because it will still include the B<use> declaration
+for the source filtering module, even though the code that is
+produced is already ordinary Perl which shouldn't be filtered again.
+
+=item *
- use constant E2BIG => ($!=7);
- use constant x=>\$x; print x
+Optimised away statements are rendered as '???'. This includes statements that
+have a compile-time side-effect, such as the obscure
-The following could (and should) be made to work:
+ my $x if 0;
- use constant regex => qr/blah/;
- print regex;
+which is not, consequently, deparsed correctly.
=item *
-An input file that uses source filtering probably won't be deparsed into
-runnable code, because it will still include the B<use> declaration
-for the source filtering module, even though the code that is
-produced is already ordinary Perl which shouldn't be filtered again.
+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
+defined within a different scope, although L<PadWalker> is a good start.
=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
https://perl5.git.perl.org / perl5.git / blobdiff