MDEREF_SHIFT
);
-$VERSION = '1.47';
+$VERSION = '1.50';
use strict;
our $AUTOLOAD;
use warnings ();
OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE
PMf_CHARSET PMf_KEEPCOPY PMf_NOCAPTURE CVf_ANONCONST
CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
- PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES
+ PMf_NONDESTRUCT OPpEVAL_BYTES
OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV
OPpLVREF_CV OPpLVREF_ELEM SVpad_STATE)) {
eval { B->import($_) };
BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
- kvaslice kvhslice padsv
+ kvaslice kvhslice padsv argcheck
nextstate dbstate rv2av rv2hv helem custom ]) {
eval "sub OP_\U$_ () { " . opnumber($_) . "}"
}}
$self->{'use_dumper'} = 0;
$self->{'use_tabs'} = 0;
- $self->{'ambient_arybase'} = 0;
$self->{'ambient_warnings'} = undef; # Assume no lexical warnings
$self->{'ambient_hints'} = 0;
$self->{'ambient_hinthash'} = undef;
sub init {
my $self = shift;
- $self->{'arybase'} = $self->{'ambient_arybase'};
$self->{'warnings'} = defined ($self->{'ambient_warnings'})
? $self->{'ambient_warnings'} & WARN_MASK
: undef;
sub ambient_pragmas {
my $self = shift;
- my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
+ my ($hint_bits, $warning_bits, $hinthash) = (0);
while (@_ > 1) {
my $name = shift();
$hint_bits |= $strict_bits{$_} for @names;
}
- elsif ($name eq '$[') {
- if (OPpCONST_ARYBASE) {
- $arybase = $val;
- } else {
- croak "\$[ can't be non-zero on this perl" unless $val == 0;
- }
- }
-
elsif ($name eq 'integer'
|| $name eq 'bytes'
|| $name eq 'utf8') {
croak "The ambient_pragmas method expects an even number of args";
}
- $self->{'ambient_arybase'} = $arybase;
$self->{'ambient_warnings'} = $warning_bits;
$self->{'ambient_hints'} = $hint_bits;
$self->{'ambient_hinthash'} = $hinthash;
# or altered. In this case we return "()" and fall back to general
# deparsing of the individual sigelems as 'my $x = $_[N]' etc.
#
-# We're only called if the first two ops are nextstate and argcheck.
+# We're only called if the top is an ex-argcheck, which is a placeholder
+# indicating a signature subtree.
+#
+# Return a signature string, or an empty list if no deparseable as a
+# signature
sub deparse_argops {
- my ($self, $firstop, $cv) = @_;
+ my ($self, $topop, $cv) = @_;
my @sig;
- my $o = $firstop;
- return if $o->label; #first nextstate;
+
+
+ $topop = $topop->first;
+ return unless $$topop and $topop->name eq 'lineseq';
+
+
+ # last op should be nextstate
+ my $last = $topop->last;
+ return unless $$last
+ and ( _op_is_or_was($last, OP_NEXTSTATE)
+ or _op_is_or_was($last, OP_DBSTATE));
+
+ # first OP_NEXTSTATE
+
+ my $o = $topop->first;
+ return unless $$o;
+ return if $o->label;
# OP_ARGCHECK
$o = $o->sibling;
+ return unless $$o and $o->name eq 'argcheck';
+
my ($params, $opt_params, $slurpy) = $o->aux_list($cv);
my $mandatory = $params - $opt_params;
my $seen_slurpy = 0;
my $last_ix = -1;
- # keep looking for valid nextstate + argelem pairs
+ # keep looking for valid nextstate + argelem pairs, terminated
+ # by a final nextstate
while (1) {
- # OP_NEXTSTATE
$o = $o->sibling;
- last unless $$o;
- last unless $o->name =~ /^(next|db)state$/;
- last if $o->label;
+ return unless $$o;
+
+ # skip trailing nextstate
+ last if $$o == $$last;
+
+ # OP_NEXTSTATE
+ return unless $o->name =~ /^(next|db)state$/;
+ return if $o->label;
# OP_ARGELEM
- my $o2 = $o->sibling;
- last unless $$o2;
+ $o = $o->sibling;
+ last unless $$o;
- if ($o2->name eq 'argelem') {
- my $ix = $o2->string($cv);
+ if ($o->name eq 'argelem') {
+ my $ix = $o->string($cv);
while (++$last_ix < $ix) {
push @sig, $last_ix < $mandatory ? '$' : '$=';
}
- my $var = $self->padname($o2->targ);
+ my $var = $self->padname($o->targ);
if ($var =~ /^[@%]/) {
return if $seen_slurpy;
$seen_slurpy = 1;
else {
return if $ix >= $params;
}
- if ($o2->flags & OPf_KIDS) {
- my $kid = $o2->first;
+ if ($o->flags & OPf_KIDS) {
+ my $kid = $o->first;
return unless $$kid and $kid->name eq 'argdefelem';
my $def = $self->deparse($kid->first, 7);
$def = "($def)" if $kid->first->flags & OPf_PARENS;
}
push @sig, $var;
}
- elsif ($o2->name eq 'null'
- and ($o2->flags & OPf_KIDS)
- and $o2->first->name eq 'argdefelem')
+ elsif ($o->name eq 'null'
+ and ($o->flags & OPf_KIDS)
+ and $o->first->name eq 'argdefelem')
{
# special case - a void context default expression: $ = expr
- my $defop = $o2->first;
+ my $defop = $o->first;
my $ix = $defop->targ;
while (++$last_ix < $ix) {
push @sig, $last_ix < $mandatory ? '$' : '$=';
push @sig, '$ = ' . $def;
}
else {
- last;
+ return;
}
- $o = $o2;
}
while (++$last_ix < $params) {
}
push @sig, $slurpy if $slurpy and !$seen_slurpy;
- return ($o, join(', ', @sig));
+ return (join(', ', @sig));
}
+
# Deparse a sub. Returns everything except the 'sub foo',
# e.g. ($$) : method { ...; }
# or : prototype($$) lvalue ($a, $b) { ...; };
$self->pad_subs($cv);
$self->pessimise($root, $cv->START);
my $lineseq = $root->first;
- if ($lineseq->name eq "lineseq") {
- my $firstop = $lineseq->first;
-
- if ($has_sig) {
- my $o2;
- # try to deparse first few ops as a signature if possible
- if ( $$firstop
- and $firstop->name =~ /^(next|db)state$/
- and (($o2 = $firstop->sibling))
- and $$o2)
- {
- if ($o2->name eq 'argcheck') {
- my ($nexto, $mysig) = $self->deparse_argops($firstop, $cv);
- if (defined $nexto) {
- $firstop = $nexto;
- $sig = $mysig;
- }
- }
- }
+
+ # stub sub may have single op rather than list of ops
+ my $is_list = ($lineseq->name eq "lineseq");
+ my $firstop = $is_list ? $lineseq->first : $lineseq;
+
+ # Try to deparse first subtree as a signature if possible.
+ # Top of signature subtree has an ex-argcheck as a placeholder
+ if ( $has_sig
+ and $$firstop
+ and $firstop->name eq 'null'
+ and $firstop->targ == OP_ARGCHECK
+ ) {
+ my ($mysig) = $self->deparse_argops($firstop, $cv);
+ if (defined $mysig) {
+ $sig = $mysig;
+ $firstop = $is_list ? $firstop->sibling : undef;
}
+ }
+ if ($is_list && $firstop) {
my @ops;
for (my $o = $firstop; $$o; $o=$o->sibling) {
push @ops, $o;
$body .= ";\n$subs" if length($subs);
}
}
- else {
+ elsif ($firstop) {
$body = $self->deparse($root->first, 0);
}
+ else {
+ $body = ';'; # stub sub
+ }
my $l = '';
if ($self->{'linenums'}) {
if $self->{'avoid_local'}{$$op};
if ($need_parens) {
return "$our_local($text)";
- } elsif (want_scalar($op)) {
+ } elsif (want_scalar($op) || $our_local eq 'our') {
return "$our_local $text";
} else {
return $self->maybe_parens_func("$our_local", $text, $cx, 16);
$self->{'curstash'} = $stash;
}
- if (OPpCONST_ARYBASE && $self->{'arybase'} != $op->arybase) {
- push @text, '$[ = '. $op->arybase .";\n";
- $self->{'arybase'} = $op->arybase;
- }
-
my $warnings = $op->warnings;
my $warning_bits;
if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
$name =~ s/^@/\$/;
my $i = $op->private;
$i -= 256 if $i > 127;
- return $name . "[" . ($i + $self->{'arybase'}) . "]";
+ return $name . "[$i]";
}
sub pp_aelemfast {
$name = $quoted ? "$name->" : '$' . $name;
my $i = $op->private;
$i -= 256 if $i > 127;
- return $name . "[" . ($i + $self->{'arybase'}) . "]";
+ return $name . "[$i]";
}
sub rv2x {
sub pp_av2arylen {
my $self = shift;
my($op, $cx) = @_;
- if ($op->first->name eq "padav") {
- return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
+ my $kid = $op->first;
+ if ($kid->name eq "padav") {
+ return $self->maybe_local($op, $cx, '$#' . $self->padany($kid));
} else {
- return $self->maybe_local($op, $cx,
- $self->rv2x($op->first, $cx, '$#'));
+ my $kkid;
+ if ( $kid->name eq "rv2av"
+ && ($kkid = $kid->first)
+ && $kkid->name !~ /^(scope|leave|gv)$/)
+ {
+ # handle (expr)->$#* postfix form
+ my $expr;
+ $expr = $self->deparse($kkid, 24); # 24 is '->'
+ $expr = "$expr->\$#*";
+ # XXX maybe_local is probably wrong here: local($#-expression)
+ # doesn't "do" local (the is no INTRO flag set)
+ return $self->maybe_local($op, $cx, $expr);
+ }
+ else {
+ # handle $#{expr} form
+ # XXX see maybe_local comment above
+ return $self->maybe_local($op, $cx, $self->rv2x($kid, $cx, '$#'));
+ }
}
}
sub pp_const {
my $self = shift;
my($op, $cx) = @_;
- if ($op->private & OPpCONST_ARYBASE) {
- return '$[';
- }
# if ($op->private & OPpCONST_BARE) { # trouble with '=>' autoquoting
# return $self->const_sv($op)->PV;
# }
my $op = shift;
my $type = $op->name;
if ($type eq "const") {
- return '$[' if $op->private & OPpCONST_ARYBASE;
return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
} elsif ($type eq "concat") {
return dq_disambiguate($self->dq($op->first), $self->dq($op->last));
my $type = $op->name;
if ($type eq "const") {
- return '$[' if $op->private & OPpCONST_ARYBASE;
my $unbacked = re_unback($self->const_sv($op)->as_string);
return re_uninterp(escape_re($unbacked));
} elsif ($type eq "concat") {
https://perl5.git.perl.org / perl5.git / blobdiff