# B::Deparse.pm
-# Copyright (c) 1998-2000, 2002, 2003 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.
use Carp;
use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
- OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
+ 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 OPpSORT_INPLACE OPpSORT_DESCEND
+ 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.69;
+ CVf_METHOD CVf_LOCKED CVf_LVALUE
+ PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
+ PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED),
+ ($] < 5.009 ? 'PMf_SKIPWHITE' : 'RXf_SKIPWHITE');
+$VERSION = 0.86;
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
# - 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)
# - here-docs?
# 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'
$name = "$self->{'curstash'}::$name" unless $name =~ /::/;
$self->{'curstash'} = $stash;
}
- $name =~ s/^\Q$stash\E:://;
+ $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
}
return "${p}${l}sub $name " . $self->deparse_sub($cv);
}
# Certain pragmas are dealt with using hint bits,
# so we ignore them here
if ($module eq 'strict' || $module eq 'integer'
- || $module eq 'bytes' || $module eq 'warnings') {
+ || $module eq 'bytes' || $module eq 'warnings'
+ || $module eq 'feature') {
return "";
}
}
my %stash = svref_2object($stash)->ARRAY;
while (my ($key, $val) = each %stash) {
- next if $key eq 'main::'; # avoid infinite recursion
my $class = class($val);
if ($class eq "PV") {
# Just a prototype. As an ugly but fairly effective way
$self->todo($cv, 1);
}
if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
- $self->stash_subs($pack . $key);
+ $self->stash_subs($pack . $key)
+ unless $pack eq '' && $key eq 'main::';
+ # avoid infinite recursion
}
}
}
$self->{'ambient_arybase'} = 0;
$self->{'ambient_warnings'} = undef; # Assume no lexical warnings
$self->{'ambient_hints'} = 0;
+ $self->{'ambient_hinthash'} = undef;
$self->init();
while (my $arg = shift @_) {
$self->{'warnings'} = defined ($self->{'ambient_warnings'})
? $self->{'ambient_warnings'} & WARN_MASK
: undef;
- $self->{'hints'} = $self->{'ambient_hints'} & 0xFF;
+ $self->{'hints'} = $self->{'ambient_hints'};
+ $self->{'hints'} &= 0xFF if $] < 5.009;
+ $self->{'hinthash'} = $self->{'ambient_hinthash'};
# also a convenient place to clear out subs_declared
delete $self->{'subs_declared'};
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, @CHECKs, @INITs, @ENDs) {
+ for my $block (@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs) {
$self->todo($block, 0);
}
$self->stash_subs();
sub ambient_pragmas {
my $self = shift;
- my ($arybase, $hint_bits, $warning_bits) = (0, 0);
+ my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
while (@_ > 1) {
my $name = shift();
$hint_bits = $val;
}
+ elsif ($name eq '%^H') {
+ $hinthash = $val;
+ }
+
else {
croak "Unknown pragma type: $name";
}
$self->{'ambient_arybase'} = $arybase;
$self->{'ambient_warnings'} = $warning_bits;
$self->{'ambient_hints'} = $hint_bits;
+ $self->{'ambient_hinthash'} = $hinthash;
}
# This method is the inner loop, so try to keep it simple
if ($cv->FLAGS & SVf_POK) {
$proto = "(". $cv->PV . ") ";
}
- if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ASSERTION)) {
+ if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
$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;
local($self->{'curcvlex'});
- local(@$self{qw'curstash warnings hints'})
- = @$self{qw'curstash warnings hints'};
+ local(@$self{qw'curstash warnings hints hinthash'})
+ = @$self{qw'curstash warnings hints hinthash'};
my $body;
if (not null $cv->ROOT) {
my $lineseq = $cv->ROOT->first;
local($self->{'curcv'}) = $form;
local($self->{'curcvlex'});
local($self->{'in_format'}) = 1;
- local(@$self{qw'curstash warnings hints'})
- = @$self{qw'curstash warnings hints'};
+ local(@$self{qw'curstash warnings hints hinthash'})
+ = @$self{qw'curstash warnings hints hinthash'};
my $op = $form->ROOT;
my $kid;
return "\f." if $op->first->name eq 'stub'
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;
if defined($self->{'limit_seq'})
&& (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
local $self->{'limit_seq'} = $limit_seq;
- for (my $i = 0; $i < @ops; $i++) {
- $expr = "";
- if (is_state $ops[$i]) {
- $expr = $self->deparse($ops[$i], 0);
- $i++;
- if ($i > $#ops) {
- push @exprs, $expr;
- last;
- }
- }
- if (!is_state $ops[$i] and (my $ls = $ops[$i+1]) and
- !null($ops[$i+1]) and $ops[$i+1]->name eq "lineseq")
- {
- if ($ls->first && !null($ls->first) && is_state($ls->first)
- && (my $sib = $ls->first->sibling)) {
- if (!null($sib) && $sib->name eq "leaveloop") {
- push @exprs, $expr . $self->for_loop($ops[$i], 0);
- $i++;
- next;
- }
- }
- }
- $expr .= $self->deparse($ops[$i], (@ops != 1)/2);
- $expr =~ s/;\n?\z//;
- push @exprs, $expr;
- }
+
+ $self->walk_lineseq($root, \@ops,
+ sub { push @exprs, $_[0]} );
+
my $body = join(";\n", grep {length} @exprs);
my $subs = "";
if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
my $kid;
my @kids;
- local(@$self{qw'curstash warnings hints'})
- = @$self{qw'curstash warnings hints'} if $real_block;
+ local(@$self{qw'curstash warnings hints hinthash'})
+ = @$self{qw'curstash warnings hints hinthash'} if $real_block;
if ($real_block) {
$kid = $op->first->sibling; # skip enter
if (is_miniwhile($kid)) {
sub deparse_root {
my $self = shift;
my($op) = @_;
- local(@$self{qw'curstash warnings hints'})
- = @$self{qw'curstash warnings hints'};
+ local(@$self{qw'curstash warnings hints hinthash'})
+ = @$self{qw'curstash warnings hints hinthash'};
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;
}
+ $self->walk_lineseq($op, \@kids,
+ sub { print $self->indent($_[0].';');
+ print "\n" unless $_[1] == $#kids;
+ });
+}
+
+sub walk_lineseq {
+ my ($self, $op, $kids, $callback) = @_;
+ my @kids = @$kids;
for (my $i = 0; $i < @kids; $i++) {
my $expr = "";
if (is_state $kids[$i]) {
- $expr = $self->deparse($kids[$i], 0);
- $i++;
+ $expr = $self->deparse($kids[$i++], 0);
if ($i > $#kids) {
- print $self->indent($expr);
+ $callback->($expr, $i);
last;
}
}
if (is_for_loop($kids[$i])) {
- $expr .= $self->for_loop($kids[$i], 0);
- $expr .= ";\n" unless $i == $#kids;
- print $self->indent($expr);
- $i++;
+ $callback->($expr . $self->for_loop($kids[$i], 0), $i++);
next;
}
$expr .= $self->deparse($kids[$i], (@kids != 1)/2);
$expr =~ s/;\n?\z//;
- $expr .= ";";
- print $self->indent($expr);
- print "\n" unless $i == $#kids;
+ $callback->($expr, $i);
}
}
Carp::confess() unless ref($gv) eq "B::GV";
my $stash = $gv->STASH->NAME;
my $name = $gv->SAFENAME;
- if (($stash eq 'main' && $globalnames{$name})
- or ($stash eq $self->{'curstash'} && !$globalnames{$name})
- or $name =~ /^[^A-Za-z_]/)
+ if ($stash eq 'main' && $name =~ /^::/) {
+ $stash = '::';
+ }
+ elsif (($stash eq 'main' && $globalnames{$name})
+ or ($stash eq $self->{'curstash'} && !$globalnames{$name}
+ && ($stash eq 'main' || $name !~ /::/))
+ or $name =~ /^[^A-Za-z_:]/)
{
$stash = "";
} else {
my ($seq_st, $seq_en) =
($ns[$i]->FLAGS & SVf_FAKE)
? (0, 999999)
- : ($ns[$i]->NVX, $ns[$i]->IVX);
+ : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH);
push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
}
carp("Undefined op in find_scope") if !defined $op;
return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
- for (my $o=$op->first; $$o; $o=$o->sibling) {
- if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
- my $s = int($self->padname_sv($o->targ)->NVX);
- my $e = $self->padname_sv($o->targ)->IVX;
- $scope_st = $s if !defined($scope_st) || $s < $scope_st;
- $scope_en = $e if !defined($scope_en) || $e > $scope_en;
- }
- elsif (is_state($o)) {
- my $c = $o->cop_seq;
- $scope_st = $c if !defined($scope_st) || $c < $scope_st;
- $scope_en = $c if !defined($scope_en) || $c > $scope_en;
- }
- elsif ($o->flags & OPf_KIDS) {
- ($scope_st, $scope_en) =
- $self->find_scope($o, $scope_st, $scope_en)
+ my @queue = ($op);
+ while(my $op = shift @queue ) {
+ for (my $o=$op->first; $$o; $o=$o->sibling) {
+ if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
+ my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW);
+ my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH;
+ $scope_st = $s if !defined($scope_st) || $s < $scope_st;
+ $scope_en = $e if !defined($scope_en) || $e > $scope_en;
+ return ($scope_st, $scope_en);
+ }
+ elsif (is_state($o)) {
+ my $c = $o->cop_seq;
+ $scope_st = $c if !defined($scope_st) || $c < $scope_st;
+ $scope_en = $c if !defined($scope_en) || $c > $scope_en;
+ return ($scope_st, $scope_en);
+ }
+ elsif ($o->flags & OPf_KIDS) {
+ unshift (@queue, $o);
+ }
}
}
$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;
+ }
+
+ # hack to check that the hint hash hasn't changed
+ if ($] > 5.009 &&
+ "@{[sort %{$self->{'hinthash'} || {}}]}"
+ ne "@{[sort %{$op->hints_hash->HASH || {}}]}") {
+ push @text, declare_hinthash($self->{'hinthash'}, $op->hints_hash->HASH, $self->{indent_size});
+ $self->{'hinthash'} = $op->hints_hash->HASH;
}
# This should go after of any branches that add statements, to
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} = ".perlstring($to)."}\n";
return $decls;
}
+# Internal implementation hints that the core sets automatically, so don't need
+# (or want) to be passed back to the user
+my %ignored_hints = (
+ 'open<' => 1,
+ 'open>' => 1,
+);
+
+sub declare_hinthash {
+ my ($from, $to, $indent) = @_;
+ my @decls;
+ for my $key (keys %$to) {
+ next if $ignored_hints{$key};
+ if (!defined $from->{$key} or $from->{$key} ne $to->{$key}) {
+ push @decls, qq(\$^H{'$key'} = q($to->{$key}););
+ }
+ }
+ for my $key (keys %$from) {
+ next if $ignored_hints{$key};
+ if (!exists $to->{$key}) {
+ push @decls, qq(delete \$^H{'$key'};);
+ }
+ }
+ @decls or return '';
+ return join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n";
+}
+
sub hint_pragmas {
my ($bits) = @_;
my @pragmas;
sub pp_each { unop(@_, "each") }
sub pp_values { unop(@_, "values") }
sub pp_keys { unop(@_, "keys") }
+sub pp_aeach { unop(@_, "each") }
+sub pp_avalues { unop(@_, "values") }
+sub pp_akeys { unop(@_, "keys") }
sub pp_pop { unop(@_, "pop") }
sub pp_shift { unop(@_, "shift") }
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 {
my $self = shift;
- my($op, $cv) = @_;
+ my($op, $cx) = @_;
my $kid = $op->first;
if (not null $kid->sibling) {
# XXX Was a here-doc
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) = @_;
my $kid = $op->first;
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
+ if (!null($kid->sibling) and
$kid->sibling->name eq "anoncode") {
- return "sub " .
- $self->deparse_sub($self->padval($kid->sibling->targ));
+ return $self->e_anoncode({ code => $self->padval($kid->sibling->targ) });
} elsif ($kid->name eq "pushmark") {
my $sib_name = $kid->sibling->name;
if ($sib_name =~ /^(pad|rv2)[ah]v$/
$self->pfixop($op, $cx, "\\", 20);
}
+sub e_anoncode {
+ my ($self, $info) = @_;
+ my $text = $self->deparse_sub($info->{code});
+ return "sub " . $text;
+}
+
sub pp_srefgen { pp_refgen(@_) }
sub pp_readline {
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->last, $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.
# 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
+ # 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)";
sub pp_prtf { indirop(@_, "printf") }
sub pp_print { indirop(@_, "print") }
+sub pp_say { indirop(@_, "say") }
sub pp_sort { indirop(@_, "sort") }
sub mapop {
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"
# specifically avoid the "reverse sort" optimisation,
# where "reverse" is nullified
- && !($lop->name eq 'sort' && ($lop->flags | OPpSORT_REVERSE)))
+ && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
{
# local()
- ($local = "", last) if $local eq "my" || $local eq "our";
+ ($local = "", last) if $local =~ /^(?:my|our|state)$/;
$local = "local";
}
}
(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);
}
return $head . join($cuddle, "", @elsifs) . $false;
}
+sub pp_once {
+ my ($self, $op, $cx) = @_;
+ my $cond = $op->first;
+ my $true = $cond->sibling;
+
+ return $self->deparse($true, $cx);
+}
+
sub loop_common {
my $self = shift;
my($op, $cx, $init) = @_;
my $enter = $op->first;
my $kid = $enter->sibling;
- local(@$self{qw'curstash warnings hints'})
- = @$self{qw'curstash warnings hints'};
+ local(@$self{qw'curstash warnings hints hinthash'})
+ = @$self{qw'curstash warnings hints hinthash'};
my $head = "";
my $bare = 0;
my $body;
} 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) . " .. " .
return $head . "{\n\t" . $body . "\b}" . $cont;
}
-sub pp_leaveloop { loop_common(@_, "") }
+sub pp_leaveloop { shift->loop_common(@_, "") }
sub for_loop {
my $self = shift;
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
}
}
-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;
}
return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
}
-sub method {
+sub _method {
my $self = shift;
my($op, $cx) = @_;
my $kid = $op->first->sibling; # skip pushmark
$obj = $kid;
$kid = $kid->sibling;
for (; not null $kid; $kid = $kid->sibling) {
- push @exprs, $self->deparse($kid, 6);
+ push @exprs, $kid;
}
} else {
$obj = $kid;
$kid = $kid->sibling;
for (; !null ($kid->sibling) && $kid->name ne "method_named";
$kid = $kid->sibling) {
- push @exprs, $self->deparse($kid, 6);
+ push @exprs, $kid
}
$meth = $kid;
}
- $obj = $self->deparse($obj, 24);
+
if ($meth->name eq "method_named") {
$meth = $self->const_sv($meth)->PV;
} else {
# As of 5.005_58, this case is probably obsoleted by the
# method_named case above
$meth = $self->const_sv($meth)->PV; # needs to be bare
- } else {
- $meth = $self->deparse($meth, 1);
}
}
- my $args = join(", ", @exprs);
- $kid = $obj . "->" . $meth;
+
+ return { method => $meth, variable_method => ref($meth),
+ object => $obj, args => \@exprs };
+}
+
+# compat function only
+sub method {
+ my $self = shift;
+ my $info = $self->_method(@_);
+ return $self->e_method( $self->_method(@_) );
+}
+
+sub e_method {
+ my ($self, $info) = @_;
+ my $obj = $self->deparse($info->{object}, 24);
+
+ my $meth = $info->{method};
+ $meth = $self->deparse($meth, 1) if $info->{variable_method};
+ my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
+ my $kid = $obj . "->" . $meth;
if (length $args) {
return $kid . "(" . $args . ")"; # parens mandatory
} else {
sub pp_entersub {
my $self = shift;
my($op, $cx) = @_;
- return $self->method($op, $cx) unless null $op->first->sibling;
+ return $self->e_method($self->_method($op, $cx))
+ unless null $op->first->sibling;
my $prefix = "";
my $amper = "";
my($kid, @exprs);
}
$simple = 1; # only calls of named functions can be prototyped
$kid = $self->deparse($kid, 24);
+ if (!$amper) {
+ if ($kid eq 'main::') {
+ $kid = '::';
+ } elsif ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
+ $kid = single_delim("q", "'", $kid) . '->';
+ }
+ }
} elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
$amper = "&";
$kid = $self->deparse($kid, 24);
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
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;
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 pp_backtick {
my $self = shift;
my($op, $cx) = @_;
- # skip pushmark
- return single_delim("qx", '`', $self->dq($op->first->sibling));
+ # skip pushmark if it exists (readpipe() vs ``)
+ my $child = $op->first->sibling->isa('B::NULL')
+ ? $op->first->first : $op->first->sibling;
+ return single_delim("qx", '`', $self->dq($child));
}
sub dquote {
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)
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 ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
+ : $kid->reflags & RXf_SKIPWHITE() ) ) {
+ $exprs[0] = "' '";
}
$expr = "split(" . join(", ", @exprs) . ")";
which specifies that the ambient pragmas are exactly those which
are in scope at the point of calling.
+=item %^H
+
+This parameter is used to specify the ambient pragmas which are
+stored in the special hash %^H.
+
=back
=head2 coderef2text
=item *
+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 *
+
There are probably many more bugs on non-ASCII platforms (EBCDIC).
=back
projects / p5sagit/p5-mst-13.2.git / blobdiff