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 OPf_PARENS
OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
- OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
+ OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST
OPpSORT_REVERSE
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
SVpad_TYPED
CVf_METHOD CVf_LVALUE
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED PMf_EXTENDED_MORE);
-$VERSION = '1.29';
+$VERSION = '1.30';
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE
RXf_PMf_CHARSET RXf_PMf_KEEPCOPY
CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
- PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES)) {
+ PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES
+ OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV
+ OPpLVREF_CV OPpLVREF_ELEM SVpad_STATE)) {
eval { import B $_ };
no strict 'refs';
*{$_} = sub () {0} unless *{$_}{CODE};
# in_subst_repl
# True when deparsing the replacement part of a substitution.
#
+# in_refgen
+# True when deparsing the argument to \.
+#
# parens: -p
# linenums: -l
# unquote: -q
-BEGIN { for (qw[ const stringify rv2sv list glob pushmark null]) {
+BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
+ custom ]) {
eval "sub OP_\U$_ () { " . opnumber($_) . "}"
}}
type => OP_PUSHMARK,
name => 'pushmark',
private => ($op->private & OPpLVAL_INTRO),
- next => ($op->flags & OPf_SPECIAL)
- ? $op->sibling->first
- : $op->sibling,
};
}
my $gv = $cv->GV;
my $name = $self->gv_name($gv);
if ($ent->[2]) {
- return "format $name =\n"
+ return $self->keyword("format") . " $name =\n"
. $self->deparse_format($ent->[1]). "\n";
} else {
$self->{'subs_declared'}{$name} = 1;
my $use_dec = $self->begin_is_use($cv);
if (defined ($use_dec) and $self->{'expand'} < 5) {
return () if 0 == length($use_dec);
+ $use_dec =~ s/^(use|no)\b/$self->keyword($1)/e;
return $use_dec;
}
}
if (class($cv->STASH) ne "SPECIAL") {
my $stash = $cv->STASH->NAME;
if ($stash ne $self->{'curstash'}) {
- $p = "package $stash;\n";
+ $p = $self->keyword("package") . " $stash;\n";
$name = "$self->{'curstash'}::$name" unless $name =~ /::/;
$self->{'curstash'} = $stash;
}
$name =~ s/^\Q$stash\E::(?!\z|.*::)//;
}
- return "${p}${l}sub $name " . $self->deparse_sub($cv);
+ return "${p}${l}" . $self->keyword("sub") . " $name "
+ . $self->deparse_sub($cv);
}
}
}
$constop = $constop->sibling;
return if $constop->name ne "method_named";
- return if $self->const_sv($constop)->PV ne "VERSION";
+ return if $self->meth_sv($constop)->PV ne "VERSION";
}
$lineseq = $version_op->sibling;
my $use = 'use';
my $method_named = $svop;
return if $method_named->name ne "method_named";
- my $method_name = $self->const_sv($method_named)->PV;
+ my $method_name = $self->meth_sv($method_named)->PV;
if ($method_name eq "unimport") {
$use = 'no';
next unless $AF eq $0 || exists $self->{'files'}{$AF};
}
push @{$self->{'protos_todo'}}, [$pack . $key, undef];
+ } elsif ($class eq "IV") {
+ # A reference. Dump this if it is a reference to a CV.
+ if (class(my $cv = $val->RV) eq "CV") {
+ $self->todo($cv, 0);
+ }
} elsif ($class eq "GV") {
if (class(my $cv = $val->CV) ne "SPECIAL") {
next if $self->{'subs_done'}{$$val}++;
my $laststash = defined $self->{'curcop'}
? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
if (defined *{$laststash."::DATA"}{IO}) {
- print "package $laststash;\n"
+ print $self->keyword("package") . " $laststash;\n"
unless $laststash eq $self->{'curstash'};
- print "__DATA__\n";
+ print $self->keyword("__DATA__") . "\n";
print readline(*{$laststash."::DATA"});
}
}
sub find_our_type {
my ($self, $name) = @_;
$self->populate_curcvlex() if !defined $self->{'curcvlex'};
- my $seq = $self->{'curcop'}->cop_seq;
+ my $seq = $self->{'curcop'} ? $self->{'curcop'}->cop_seq : 0;
for my $a (@{$self->{'curcvlex'}{"o$name"}}) {
my ($st, undef, $padname) = @$a;
- if ($st == $seq && $padname->FLAGS & SVpad_TYPED) {
+ if ($st >= $seq && $padname->FLAGS & SVpad_TYPED) {
return $padname->SvSTASH->NAME;
}
}
sub maybe_local {
my $self = shift;
my($op, $cx, $text) = @_;
- my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
- if ($op->private & (OPpLVAL_INTRO|$our_intro)) {
- my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
- if( $our_local eq 'our' ) {
+ my $name = $op->name;
+ my $our_intro = ($name =~ /^(?:(?:gv|rv2)[ash]v|split|refassign
+ |lv(?:av)?ref)$/x)
+ ? OPpOUR_INTRO
+ : 0;
+ my $lval_intro = $name eq 'split' ? 0 : OPpLVAL_INTRO;
+ # The @a in \(@a) isn't in ref context, but only when the
+ # parens are there.
+ my $need_parens = $self->{'in_refgen'} && $name =~ /[ah]v\z/
+ && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
+ if ((my $priv = $op->private) & ($lval_intro|$our_intro)) {
+ my @our_local;
+ push @our_local, "local" if $priv & $lval_intro;
+ push @our_local, "our" if $priv & $our_intro;
+ my $our_local = join " ", map $self->keyword($_), @our_local;
+ if( $our_local[-1] eq 'our' ) {
if ( $text !~ /^\W(\w+::)*\w+\z/
and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
) {
$our_local .= ' ' . $type;
}
}
- return $text if $self->{'avoid_local'}{$$op};
- if (want_scalar($op)) {
+ return $need_parens ? "($text)" : $text
+ if $self->{'avoid_local'}{$$op};
+ if ($need_parens) {
+ return "$our_local($text)";
+ } elsif (want_scalar($op)) {
return "$our_local $text";
} else {
return $self->maybe_parens_func("$our_local", $text, $cx, 16);
}
} else {
- return $text;
+ return $need_parens ? "($text)" : $text;
}
}
sub maybe_my {
my $self = shift;
my($op, $cx, $text, $padname, $forbid_parens) = @_;
+ # The @a in \(@a) isn't in ref context, but only when the
+ # parens are there.
+ my $need_parens = !$forbid_parens && $self->{'in_refgen'}
+ && $op->name =~ /[ah]v\z/
+ && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
- my $my = $op->private & OPpPAD_STATE
- ? $self->keyword("state")
- : "my";
+ # Check $padname->FLAGS for statehood, rather than $op->private,
+ # because enteriter ops do not carry the flag.
+ my $my =
+ $self->keyword($padname->FLAGS & SVpad_STATE ? "state" : "my");
if ($padname->FLAGS & SVpad_TYPED) {
$my .= ' ' . $padname->SvSTASH->NAME;
}
- if ($forbid_parens || want_scalar($op)) {
+ if ($need_parens) {
+ return "$my($text)";
+ } elsif ($forbid_parens || want_scalar($op)) {
return "$my $text";
} else {
return $self->maybe_parens_func($my, $text, $cx, 16);
}
} else {
- return $text;
+ return $need_parens ? "($text)" : $text;
}
}
sub AUTOLOAD {
if ($AUTOLOAD =~ s/^.*::pp_//) {
- warn "unexpected OP_".uc $AUTOLOAD;
+ warn "unexpected OP_".
+ ($_[1]->type == OP_CUSTOM ? "CUSTOM ($AUTOLOAD)" : uc $AUTOLOAD);
return "XXX";
} else {
die "Undefined subroutine $AUTOLOAD called";
my $top = $kid->first;
my $name = $top->name;
if ($name eq "and") {
- $name = "while";
+ $name = $self->keyword("while");
} elsif ($name eq "or") {
- $name = "until";
+ $name = $self->keyword("until");
} else { # no conditional -> while 1 or until 0
- return $self->deparse($top->first, 1) . " while 1";
+ return $self->deparse($top->first, 1) . " "
+ . $self->keyword("while") . " 1";
}
my $cond = $top->first;
my $body = $cond->sibling->first; # skip lineseq
}
if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
my $body = $self->lineseq($op, 0, @kids);
- return is_lexical_subs(@kids) ? $body : "do {\n\t$body\n\b}";
+ return is_lexical_subs(@kids)
+ ? $body
+ : ($self->lex_in_scope("&do") ? "CORE::do" : "do")
+ . " {\n\t$body\n\b}";
} else {
my $lineseq = $self->lineseq($op, $cx, @kids);
return (length ($lineseq) ? "$lineseq;" : "");
$i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
next;
}
- $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
+ my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2);
+ $expr2 =~ s/^sub :/+sub :/; # statement label otherwise
+ $expr .= $expr2;
$expr =~ s/;\n?\z//;
$callback->($expr, $i);
}
return $name, 0; # not quoted
}
else {
- single_delim("q", "'", $name), 1;
+ single_delim("q", "'", $name, $self), 1;
}
}
sub cop_subs {
my ($self, $op, $out_seq) = @_;
my $seq = $op->cop_seq;
- # If we have nephews, then our sequence number indicates
- # the cop_seq of the end of some sort of scope.
- if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
+ if ($] < 5.021006) {
+ # If we have nephews, then our sequence number indicates
+ # the cop_seq of the end of some sort of scope.
+ if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
and my $nseq = $self->find_scope_st($op->sibling) ) {
$seq = $nseq;
+ }
}
$seq = $out_seq if defined($out_seq) && $out_seq < $seq;
return $self->seq_subs($seq);
#push @text, "# ($seq)\n";
return "" if !defined $seq;
+ my @pending;
while (scalar(@{$self->{'subs_todo'}})
and $seq > $self->{'subs_todo'}[0][0]) {
+ my $cv = $self->{'subs_todo'}[0][1];
+ my $outside = $cv && $cv->OUTSIDE;
+ if ($cv and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}}) {
+ push @pending, shift @{$self->{'subs_todo'}};
+ next;
+ }
push @text, $self->next_todo;
}
+ unshift @{$self->{'subs_todo'}}, @pending;
return @text;
}
push @text, $self->cop_subs($op);
my $stash = $op->stashpv;
if ($stash ne $self->{'curstash'}) {
- push @text, "package $stash;\n";
+ push @text, $self->keyword("package") . " $stash;\n";
$self->{'curstash'} = $stash;
}
if (defined ($warning_bits) and
!defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
- push @text, declare_warnings($self->{'warnings'}, $warning_bits);
+ push @text,
+ $self->declare_warnings($self->{'warnings'}, $warning_bits);
$self->{'warnings'} = $warning_bits;
}
my $hints = $] < 5.008009 ? $op->private : $op->hints;
my $old_hints = $self->{'hints'};
if ($self->{'hints'} != $hints) {
- push @text, declare_hints($self->{'hints'}, $hints);
+ push @text, $self->declare_hints($self->{'hints'}, $hints);
$self->{'hints'} = $hints;
}
my $bundle =
$feature::hint_bundles[$to >> $feature::hint_shift];
$bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12
- push @text, "no feature;\n",
- "use feature ':$bundle';\n";
+ push @text,
+ $self->keyword("no") . " feature;\n",
+ $self->keyword("use") . " feature ':$bundle';\n";
}
}
}
if ($] > 5.009) {
- push @text, declare_hinthash(
+ push @text, $self->declare_hinthash(
$self->{'hinthash'}, $newhh,
$self->{indent_size}, $self->{hints},
);
}
sub declare_warnings {
- my ($from, $to) = @_;
+ my ($self, $from, $to) = @_;
if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
- return "use warnings;\n";
+ return $self->keyword("use") . " warnings;\n";
}
elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
- return "no warnings;\n";
+ return $self->keyword("no") . " warnings;\n";
}
return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n";
}
sub declare_hints {
- my ($from, $to) = @_;
+ my ($self, $from, $to) = @_;
my $use = $to & ~$from;
my $no = $from & ~$to;
my $decls = "";
for my $pragma (hint_pragmas($use)) {
- $decls .= "use $pragma;\n";
+ $decls .= $self->keyword("use") . " $pragma;\n";
}
for my $pragma (hint_pragmas($no)) {
- $decls .= "no $pragma;\n";
+ $decls .= $self->keyword("no") . " $pragma;\n";
}
return $decls;
}
my %rev_feature;
sub declare_hinthash {
- my ($from, $to, $indent, $hints) = @_;
+ my ($self, $from, $to, $indent, $hints) = @_;
my $doing_features =
($hints & $feature::hint_mask) == $feature::hint_mask;
my @decls;
if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) {
push(@features, $key), next if $is_feature;
push @decls,
- qq(\$^H{) . single_delim("q", "'", $key) . qq(} = )
+ qq(\$^H{) . single_delim("q", "'", $key, $self) . qq(} = )
. (
defined $to->{$key}
- ? single_delim("q", "'", $to->{$key})
+ ? single_delim("q", "'", $to->{$key}, $self)
: 'undef'
)
. qq(;);
if (!%rev_feature) { %rev_feature = reverse %feature::feature }
}
if (@features) {
- push @ret, "use feature "
+ push @ret, $self->keyword("use") . " feature "
. join(", ", map "'$rev_feature{$_}'", @features) . ";\n";
}
if (@unfeatures) {
- push @ret, "no feature "
+ push @ret, $self->keyword("no") . " feature "
. join(", ", map "'$rev_feature{$_}'", @unfeatures)
. ";\n";
}
undef
);
-sub keyword {
- my $self = shift;
- my $name = shift;
- return $name if $name =~ /^CORE::/; # just in case
- if (exists $feature_keywords{$name}) {
+sub feature_enabled {
+ my($self,$name) = @_;
my $hh;
my $hints = $self->{hints} & $feature::hint_mask;
if ($hints && $hints != $feature::hint_mask) {
$hh = _features_from_bundle($hints);
}
elsif ($hints) { $hh = $self->{'hinthash'} }
- return "CORE::$name"
- if !$hh
- || !$hh->{"feature_$feature_keywords{$name}"}
+ return $hh && $hh->{"feature_$feature_keywords{$name}"}
+}
+
+sub keyword {
+ my $self = shift;
+ my $name = shift;
+ return $name if $name =~ /^CORE::/; # just in case
+ if (exists $feature_keywords{$name}) {
+ return "CORE::$name" if not $self->feature_enabled($name);
+ }
+ # This sub may be called for a program that has no nextstate ops. In
+ # that case we may have a lexical sub named no/use/sub in scope but
+ # but $self->lex_in_scope will return false because it depends on the
+ # current nextstate op. So we need this alternate method if there is
+ # no current cop.
+ if (!$self->{'curcop'}) {
+ $self->populate_curcvlex() if !defined $self->{'curcvlex'};
+ return "CORE::$name" if exists $self->{'curcvlex'}{"m&$name"}
+ || exists $self->{'curcvlex'}{"o&$name"};
+ } elsif ($self->lex_in_scope("&$name")
+ || $self->lex_in_scope("&$name", 1)) {
+ return "CORE::$name";
}
if ($strong_proto_keywords{$name}
|| ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
my $self = shift;
my($op, $cx) = @_;
my $arg;
+ my $name = $self->keyword("exists");
if ($op->private & OPpEXISTS_SUB) {
# Checking for the existence of a subroutine
- return $self->maybe_parens_func("exists",
+ return $self->maybe_parens_func($name,
$self->pp_rv2cv($op->first, 16), $cx, 16);
}
if ($op->flags & OPf_SPECIAL) {
# Array element, not hash element
- return $self->maybe_parens_func("exists",
+ return $self->maybe_parens_func($name,
$self->pp_aelem($op->first, 16), $cx, 16);
}
- return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
+ return $self->maybe_parens_func($name, $self->pp_helem($op->first, 16),
$cx, 16);
}
my $self = shift;
my($op, $cx) = @_;
my $arg;
+ my $name = $self->keyword("delete");
if ($op->private & OPpSLICE) {
if ($op->flags & OPf_SPECIAL) {
# Deleting from an array, not a hash
- return $self->maybe_parens_func("delete",
+ return $self->maybe_parens_func($name,
$self->pp_aslice($op->first, 16),
$cx, 16);
}
- return $self->maybe_parens_func("delete",
+ return $self->maybe_parens_func($name,
$self->pp_hslice($op->first, 16),
$cx, 16);
} else {
if ($op->flags & OPf_SPECIAL) {
# Deleting from an array, not a hash
- return $self->maybe_parens_func("delete",
+ return $self->maybe_parens_func($name,
$self->pp_aelem($op->first, 16),
$cx, 16);
}
- return $self->maybe_parens_func("delete",
+ return $self->maybe_parens_func($name,
$self->pp_helem($op->first, 16),
$cx, 16);
}
my($op, $cx) = @_;
my $kid = $op->first;
if ($kid->name eq "null") {
- $kid = $kid->first;
- if (!null($kid->sibling) and
- $kid->sibling->name eq "anoncode") {
- return $self->e_anoncode({ code => $self->padval($kid->sibling->targ) });
+ my $anoncode = $kid = $kid->first;
+ if ($anoncode->name eq "anoncode"
+ or !null($anoncode = $kid->sibling) and
+ $anoncode->name eq "anoncode") {
+ return $self->e_anoncode({ code => $self->padval($anoncode->targ) });
} elsif ($kid->name eq "pushmark") {
my $sib_name = $kid->sibling->name;
- if ($sib_name =~ /^(pad|rv2)[ah]v$/
- and not $kid->sibling->flags & OPf_REF)
- {
- # The @a in \(@a) isn't in ref context, but only when the
- # parens are there.
- return "\\(" . $self->pp_list($op->first) . ")";
- } elsif ($sib_name eq 'entersub') {
+ if ($sib_name eq 'entersub') {
my $text = $self->deparse($kid->sibling, 1);
# Always show parens for \(&func()), but only with -p otherwise
$text = "($text)" if $self->{'parens'}
}
}
}
+ local $self->{'in_refgen'} = 1;
$self->pfixop($op, $cx, "\\", 20);
}
sub e_anoncode {
my ($self, $info) = @_;
my $text = $self->deparse_sub($info->{code});
- return "sub " . $text;
+ return $self->keyword("sub") . " $text";
}
sub pp_srefgen { pp_refgen(@_) }
'multiply=' => 7, 'i_multiply=' => 7,
'divide=' => 7, 'i_divide=' => 7,
'modulo=' => 7, 'i_modulo=' => 7,
- 'repeat=' => 7,
+ 'repeat=' => 7, 'refassign' => 7, 'refassign=' => 7,
'add=' => 7, 'i_add=' => 7,
'subtract=' => 7, 'i_subtract=' => 7,
'concat=' => 7,
if ($flags & SWAP_CHILDREN) {
($left, $right) = ($right, $left);
}
+ my $leftop = $left;
$left = $self->deparse_binop_left($op, $left, $prec);
$left = "($left)" if $flags & LIST_CONTEXT
- && $left !~ /^(my|our|local|)[\@\(]/;
+ and $left !~ /^(my|our|local|)[\@\(]/
+ || do {
+ # Parenthesize if the left argument is a
+ # lone repeat op.
+ my $left = $leftop->first->sibling;
+ $left->name eq 'repeat'
+ && null($left->sibling);
+ };
$right = $self->deparse_binop_right($op, $right, $prec);
return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
}
return $self->maybe_parens("$left .$eq $right", $cx, $prec);
}
+sub pp_repeat { maybe_targmy(@_, \&repeat) }
+
# 'x' is weird when the left arg is a list
-sub pp_repeat {
+sub repeat {
my $self = shift;
my($op, $cx) = @_;
my $left = $op->first;
$prec = 7;
}
if (null($right)) { # list repeat; count is inside left-side ex-list
+ # in 5.21.5 and earlier
my $kid = $left->first->sibling; # skip pushmark
my @exprs;
for (; !null($kid->sibling); $kid = $kid->sibling) {
$right = $kid;
$left = "(" . join(", ", @exprs). ")";
} else {
- $left = $self->deparse_binop_left($op, $left, $prec);
+ my $dolist = $op->private & OPpREPEAT_DOLIST;
+ $left = $self->deparse_binop_left($op, $left, $dolist ? 1 : $prec);
+ if ($dolist) {
+ $left = "($left)";
+ }
}
$right = $self->deparse_binop_right($op, $right, $prec);
return $self->maybe_parens("$left x$eq $right", $cx, $prec);
my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
my $left = $op->first;
my $right = $op->first->sibling;
+ $blockname &&= $self->keyword($blockname);
if ($cx < 1 and is_scope($right) and $blockname
and $self->{'expand'} < 7)
{ # if ($a) {$b}
}
maybe_local(@_, listop(@_, "substr"))
}
-sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
+sub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) }
sub pp_index { maybe_targmy(@_, \&listop, "index") }
sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
$expr = $self->deparse($kid, 6);
push @exprs, $expr if defined $expr;
}
- return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
+ return $self->maybe_parens_func($self->keyword($name),
+ $code . join(", ", @exprs), $cx, 5);
}
sub pp_mapwhile { mapop(@_, "map") }
sub pp_mapstart { baseop(@_, "map") }
sub pp_grepstart { baseop(@_, "grep") }
+my %uses_intro;
+BEGIN {
+ @uses_intro{
+ eval { require B::Op_private }
+ ? @{$B::Op_private::ops_using{OPpLVAL_INTRO}}
+ : qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice
+ hslice delete padsv padav padhv enteriter entersub padrange
+ pushmark cond_expr refassign list)
+ } = ();
+ delete @uses_intro{qw( lvref lvrefslice lvavref )};
+}
+
sub pp_list {
my $self = shift;
my($op, $cx) = @_;
my $local = "either"; # could be local(...), my(...), state(...) or our(...)
my $type;
for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
- # This assumes that no other private flags equal 128, and that
- # OPs that store things other than flags in their op_private,
- # like OP_AELEMFAST, won't be immediate children of a list.
- #
- # OP_ENTERSUB and OP_SPLIT can break this logic, so check for them.
- # I suspect that open and exit can too.
- # XXX This really needs to be rewritten to accept only those ops
- # known to take the OPpLVAL_INTRO flag.
-
my $lopname = $lop->name;
- if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
- or $lopname eq "undef")
- or $lopname =~ /^(?:entersub|exit|open|split)\z/)
- {
- $local = ""; # or not
- last;
- }
+ my $loppriv = $lop->private;
my $newtype;
- if ($lopname =~ /^pad[ash]v$/) {
- if ($lop->private & OPpPAD_STATE) { # state()
- ($local = "", last) if $local =~ /^(?:local|our|my)$/;
+ if ($lopname =~ /^pad[ash]v$/ && $loppriv & OPpLVAL_INTRO) {
+ if ($loppriv & OPpPAD_STATE) { # state()
+ ($local = "", last) if $local !~ /^(?:either|state)$/;
$local = "state";
} else { # my()
- ($local = "", last) if $local =~ /^(?:local|our|state)$/;
+ ($local = "", last) if $local !~ /^(?:either|my)$/;
$local = "my";
}
my $padname = $self->padname_sv($lop->targ);
$newtype = $padname->SvSTASH->NAME;
}
} elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/
- && $lop->private & OPpOUR_INTRO
+ && $loppriv & OPpOUR_INTRO
or $lopname eq "null" && $lop->first->name eq "gvsv"
&& $lop->first->private & OPpOUR_INTRO) { # our()
- ($local = "", last) if $local =~ /^(?:my|local|state)$/;
- $local = "our";
+ my $newlocal = "local " x !!($loppriv & OPpLVAL_INTRO) . "our";
+ ($local = "", last)
+ if $local ne 'either' && $local ne $newlocal;
+ $local = $newlocal;
my $funny = !$1 || $1 eq 's' ? '$' : $1 eq 'a' ? '@' : '%';
if (my $t = $self->find_our_type(
$funny . $self->gv_or_padgv($lop->first)->NAME
)) {
$newtype = $t;
}
- } elsif ($lopname ne "undef"
- # specifically avoid the "reverse sort" optimisation,
- # where "reverse" is nullified
- && !($lopname eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
+ } elsif ($lopname ne 'undef'
+ and !($loppriv & OPpLVAL_INTRO)
+ || !exists $uses_intro{$lopname eq 'null'
+ ? substr B::ppname($lop->targ), 3
+ : $lopname})
+ {
+ $local = ""; # or not
+ last;
+ } elsif ($lopname ne "undef")
{
# local()
- ($local = "", last) if $local =~ /^(?:my|our|state)$/;
+ ($local = "", last) if $local !~ /^(?:either|local)$/;
$local = "local";
}
if (defined $type && defined $newtype && $newtype ne $type) {
$type = $newtype;
}
$local = "" if $local eq "either"; # no point if it's all undefs
+ $local &&= join ' ', map $self->keyword($_), split / /, $local;
$local .= " $type " if $local && length $type;
return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
for (; !null($kid); $kid = $kid->sibling) {
$cond = $self->deparse($cond, 1);
$true = $self->deparse($true, 0);
- my $head = "if ($cond) {\n\t$true\n\b}";
+ my $head = $self->keyword("if") . " ($cond) {\n\t$true\n\b}";
my @elsifs;
+ my $elsif;
while (!null($false) and is_ifelse_cont($false)) {
my $newop = $false->first;
my $newcond = $newop->first;
}
$newcond = $self->deparse($newcond, 1);
$newtrue = $self->deparse($newtrue, 0);
- push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
+ $elsif ||= $self->keyword("elsif");
+ push @elsifs, "$elsif ($newcond) {\n\t$newtrue\n\b}";
}
if (!null($false)) {
- $false = $cuddle . "else {\n\t" .
+ $false = $cuddle . $self->keyword("else") . " {\n\t" .
$self->deparse($false, 0) . "\n\b}\cK";
} else {
$false = "\cK";
my $cond = $op->first;
my $true = $cond->sibling;
- return $self->deparse($true, $cx);
+ my $ret = $self->deparse($true, $cx);
+ $ret =~ s/^(\(?)\$/$1 . $self->keyword("state") . ' $'/e;
+ $ret;
}
sub loop_common {
my $bare = 0;
my $body;
my $cond = undef;
+ my $name;
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
}
} elsif ($var->name eq "gv") {
$var = "\$" . $self->deparse($var, 1);
+ } else {
+ $var = $self->deparse($var, 1);
}
$body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
if (!is_state $body->first and $body->first->name !~ /^(?:stub|leave|scope)$/) {
confess unless $var eq '$_';
$body = $body->first;
- return $self->deparse($body, 2) . " foreach ($ary)";
+ return $self->deparse($body, 2) . " "
+ . $self->keyword("foreach") . " ($ary)";
}
$head = "foreach $var ($ary) ";
} elsif ($kid->name eq "null") { # while/until
$kid = $kid->first;
- my $name = {"and" => "while", "or" => "until"}->{$kid->name};
- $cond = $self->deparse($kid->first, 1);
- $head = "$name ($cond) ";
+ $name = {"and" => "while", "or" => "until"}->{$kid->name};
+ $cond = $kid->first;
$body = $kid->first->sibling;
} elsif ($kid->name eq "stub") { # bare and empty
return "{;}"; # {} could be a hashref
# block (or the last in a bare loop).
my $cont_start = $enter->nextop;
my $cont;
+ my $precond;
+ my $postcond;
if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
if ($bare) {
$cont = $body->last;
}
$body = $self->lineseq(undef, 0, @states);
if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
- $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
+ $precond = "for ($init; ";
+ $postcond = "; " . $self->deparse($cont, 1) .") ";
$cont = "\cK";
} else {
$cont = $cuddle . "continue {\n\t" .
} else {
return "" if !defined $body;
if (length $init) {
- $head = "for ($init; $cond;) ";
+ $precond = "for ($init; ";
+ $postcond = ";) ";
}
$cont = "\cK";
$body = $self->deparse($body, 0);
}
+ if ($precond) { # for(;;)
+ $cond &&= $name eq 'until'
+ ? listop($self, undef, 1, "not", $cond->first)
+ : $self->deparse($cond, 1);
+ $head = "$precond$cond$postcond";
+ }
+ if ($name && !$head) {
+ ref $cond and $cond = $self->deparse($cond, 1);
+ $head = "$name ($cond) ";
+ }
+ $head =~ s/^(for(?:each)?|while|until)/$self->keyword($1)/e;
$body =~ s/;?$/;\n/;
return $head . "{\n\t" . $body . "\b}" . $cont;
. $self->deparse($op->first->sibling, 20),
$cx, 20);
} elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
- return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
+ return ($self->lex_in_scope("&do") ? "CORE::do" : "do")
+ . " {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
} elsif (!null($op->first->sibling) and
$op->first->sibling->name eq "null" and
class($op->first->sibling) eq "UNOP" and
}
if ($meth->name eq "method_named") {
- $meth = $self->const_sv($meth)->PV;
+ $meth = $self->meth_sv($meth)->PV;
} else {
$meth = $meth->first;
if ($meth->name eq "const") {
if (!$amper) {
if ($kid eq 'main::') {
$kid = '::';
- } elsif ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
- $kid = single_delim("q", "'", $kid) . '->';
+ }
+ else {
+ if ($kid !~ /::/ && $kid ne 'x') {
+ # Fully qualify any sub name that is also a keyword. While
+ # we could check the import flag, we cannot guarantee that
+ # the code deparsed so far would set that flag, so we qual-
+ # ify the names regardless of importation.
+ my $fq;
+ if (exists $feature_keywords{$kid}) {
+ $fq++ if $self->feature_enabled($kid);
+ } elsif (do { local $@; local $SIG{__DIE__};
+ eval { () = prototype "CORE::$kid"; 1 } }) {
+ $fq++
+ }
+ $fq and substr $kid, 0, 0, = $self->{'curstash'}.'::';
+ }
+ if ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
+ $kid = single_delim("q", "'", $kid, $self) . '->';
+ }
}
}
} elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
}
sub single_delim {
- my($q, $default, $str) = @_;
+ my($q, $default, $str, $self) = @_;
return "$default$str$default" if $default and index($str, $default) == -1;
+ my $coreq = $self->keyword($q); # maybe CORE::q
if ($q ne 'qr') {
(my $succeed, $str) = balanced_delim($str);
- return "$q$str" if $succeed;
+ return "$coreq$str" if $succeed;
}
for my $delim ('/', '"', '#') {
- return "$q$delim" . $str . $delim if index($str, $delim) == -1;
+ return "$coreq$delim" . $str . $delim if index($str, $delim) == -1;
}
if ($default) {
$str =~ s/$default/\\$default/g;
return "$default$str$default";
} else {
$str =~ s[/][\\/]g;
- return "$q/$str/";
+ return "$coreq/$str/";
}
}
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 single_delim("qr", "", $re, $self);
}
}
}
} elsif ($sv->FLAGS & SVf_POK) {
my $str = $sv->PV;
if ($str =~ /[[:^print:]]/) {
- return single_delim("qq", '"', uninterp escape_str unback $str);
+ return single_delim("qq", '"',
+ uninterp(escape_str unback $str), $self);
} else {
- return single_delim("q", "'", unback $str);
+ return single_delim("q", "'", unback($str), $self);
}
} else {
return "undef";
return $sv;
}
+sub meth_sv {
+ my $self = shift;
+ my $op = shift;
+ my $sv = $op->meth_sv;
+ # the constant could be in the pad (under useithreads)
+ $sv = $self->padval($op->targ) unless $$sv;
+ return $sv;
+}
+
sub pp_const {
my $self = shift;
my($op, $cx) = @_;
my $child = $op->first->sibling->isa('B::NULL')
? $op->first : $op->first->sibling;
if ($self->pure_string($child)) {
- return single_delim("qx", '`', $self->dq($child, 1));
+ return single_delim("qx", '`', $self->dq($child, 1), $self);
}
unop($self, @_, "readpipe");
}
my $kid = $op->first->sibling; # skip ex-stringify, pushmark
return $self->deparse($kid, $cx) if $self->{'unquote'};
$self->maybe_targmy($kid, $cx,
- sub {single_delim("qq", '"', $self->dq($_[1]))});
+ sub {single_delim("qq", '"', $self->dq($_[1]),
+ $self)});
}
# OP_STRINGIFY is a listop, but it only ever has one arg
-sub pp_stringify { maybe_targmy(@_, \&dquote) }
+sub pp_stringify {
+ my ($self, $op, $cx) = @_;
+ my $kid = $op->first->sibling;
+ while ($kid->name eq 'null' && !null($kid->first)) {
+ $kid = $kid->first;
+ }
+ if ($kid->name =~ /^(?:const|padsv|rv2sv|av2arylen|gvsv
+ |aelemfast(?:_lex)?|[ah]elem|join|concat)\z/x) {
+ maybe_targmy(@_, \&dquote);
+ }
+ else {
+ # Actually an optimised join.
+ my $result = listop(@_,"join");
+ $result =~ s/join([( ])/join$1$self->{'ex_const'}, /;
+ $result;
+ }
+}
# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
# note that tr(from)/to/ is OK, but not tr/from/(to)
sub pp_trans {
my $self = shift;
- my($op, $cx) = @_;
+ my($op, $cx, $morflags) = @_;
my($from, $to);
my $class = class($op);
my $priv_flags = $op->private;
$flags .= "d" if $priv_flags & OPpTRANS_DELETE;
$to = "" if $from eq $to and $flags eq "";
$flags .= "s" if $priv_flags & OPpTRANS_SQUASH;
- return "tr" . double_delim($from, $to) . $flags;
+ $flags .= $morflags if defined $morflags;
+ my $ret = $self->keyword("tr") . double_delim($from, $to) . $flags;
+ if (my $targ = $op->targ) {
+ return $self->maybe_parens($self->padname($targ) . " =~ $ret",
+ $cx, 20);
+ }
+ return $ret;
}
-sub pp_transr { &pp_trans . 'r' }
+sub pp_transr { push @_, 'r'; goto &pp_trans }
sub re_dq_disambiguate {
my ($first, $last) = @_;
$var = $self->deparse($kid, 20);
$kid = $kid->sibling;
}
+ elsif ($name eq 'match' and my $targ = $op->targ) {
+ $binop = 1;
+ $var = $self->padname($targ);
+ }
my $quote = 1;
my $pmflags = $op->pmflags;
my $extended = ($pmflags & PMf_EXTENDED);
$flags = $matchwords{$flags} if $matchwords{$flags};
if ($pmflags & PMf_ONCE) { # only one kind of delimiter works here
$re =~ s/\?/\\?/g;
- $re = "m?$re?"; # explicit 'm' is required
+ $re = $self->keyword("m") . "?$re?"; # explicit 'm' is required
} elsif ($quote) {
- $re = single_delim($name, $delim, $re);
+ $re = single_delim($name, $delim, $re, $self);
}
$re = $re . $flags if $quote;
if ($binop) {
sub pp_runcv { unop(@_, "__SUB__"); }
sub pp_split {
+ maybe_targmy(@_, \&split);
+}
+sub split {
my $self = shift;
my($op, $cx) = @_;
my($kid, @exprs, $ary, $expr);
# figures out for us which it is.
my $replroot = $kid->pmreplroot;
my $gv = 0;
+ my $stacked = $op->flags & OPf_STACKED;
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), $cx) if $gv;
-
- for (; !null($kid); $kid = $kid->sibling) {
+ } elsif ($kid->targ) {
+ $ary = $self->padname($kid->targ)
+ } elsif ($stacked) {
+ $ary = $self->deparse($op->last, 7);
+ }
+ $ary = $self->maybe_local(@_,
+ $self->stash_variable('@',
+ $self->gv_name($gv),
+ $cx))
+ if $gv;
+
+ # Skip the last kid when OPf_STACKED is set, since it is the array
+ # on the left.
+ for (; !null($stacked ? $kid->sibling : $kid); $kid = $kid->sibling) {
push @exprs, $self->deparse($kid, 6);
}
$var = $self->deparse($kid, 20);
$kid = $kid->sibling;
}
+ elsif (my $targ = $op->targ) {
+ $binop = 1;
+ $var = $self->padname($targ);
+ }
my $flags = "";
my $pmflags = $op->pmflags;
if (null($op->pmreplroot)) {
$flags .= $self->re_flags($op);
$flags = join '', sort split //, $flags;
$flags = $substwords{$flags} if $substwords{$flags};
+ my $core_s = $self->keyword("s"); # maybe CORE::s
if ($binop) {
- return $self->maybe_parens("$var =~ s"
+ return $self->maybe_parens("$var =~ $core_s"
. double_delim($re, $repl) . $flags,
$cx, 20);
} else {
- return "s". double_delim($re, $repl) . $flags;
+ return "$core_s". double_delim($re, $repl) . $flags;
}
}
return $self->padany($op);
}
+my %lvref_funnies = (
+ OPpLVREF_SV, => '$',
+ OPpLVREF_AV, => '@',
+ OPpLVREF_HV, => '%',
+ OPpLVREF_CV, => '&',
+);
+
+sub pp_refassign {
+ my ($self, $op, $cx) = @_;
+ my $left;
+ if ($op->private & OPpLVREF_ELEM) {
+ $left = $op->first->sibling;
+ $left = maybe_local(@_, elem($self, $left, undef,
+ $left->targ == OP_AELEM
+ ? qw([ ] padav)
+ : qw({ } padhv)));
+ } elsif ($op->flags & OPf_STACKED) {
+ $left = maybe_local(@_,
+ $lvref_funnies{$op->private & OPpLVREF_TYPE}
+ . $self->deparse($op->first->sibling));
+ } else {
+ $left = &pp_padsv;
+ }
+ my $right = $self->deparse_binop_right($op, $op->first, 7);
+ return $self->maybe_parens("\\$left = $right", $cx, 7);
+}
+
+sub pp_lvref {
+ my ($self, $op, $cx) = @_;
+ my $code;
+ if ($op->private & OPpLVREF_ELEM) {
+ $code = $op->first->name =~ /av\z/ ? &pp_aelem : &pp_helem;
+ } elsif ($op->flags & OPf_STACKED) {
+ $code = maybe_local(@_,
+ $lvref_funnies{$op->private & OPpLVREF_TYPE}
+ . $self->deparse($op->first));
+ } else {
+ $code = &pp_padsv;
+ }
+ "\\$code";
+}
+
+sub pp_lvrefslice {
+ my ($self, $op, $cx) = @_;
+ '\\' . ($op->last->name =~ /av\z/ ? &pp_aslice : &pp_hslice);
+}
+
+sub pp_lvavref {
+ my ($self, $op, $cx) = @_;
+ '\\(' . ($op->flags & OPf_STACKED
+ ? maybe_local(@_, rv2x(@_, "\@"))
+ : &pp_padsv) . ')'
+}
+
1;
__END__
=item *
-The only pragmas to be completely supported are: C<use warnings>,
+In Perl 5.20 and earlier, the only pragmas to
+be completely supported are: C<use warnings>,
C<use strict>, C<use bytes>, C<use integer>
and C<use feature>. (C<$[>, which
behaves like a pragma, is also supported.)
(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 require some help
-from the Perl core to fix.
+This is the most serious problem in Perl 5.20 and earlier. Fixing this
+required internal changes in Perl 5.22.
=item *
=item *
-Optimised away statements are rendered as
+Optimized-away statements are rendered as
'???'. This includes statements that
have a compile-time side-effect, such as the obscure
problem, as perl has no native facility for referring to a lexical variable
defined within a different scope, although L<PadWalker> is a good start.
+See also L<Data::Dump::Streamer>, which combines B::Deparse and
+L<PadWalker> to serialize closures properly.
+
=item *
There are probably many more bugs on non-ASCII platforms (EBCDIC).
https://perl5.git.perl.org / perl5.git / blobdiff