# B::Deparse.pm
-# Copyright (c) 1998, 1999 Stephen McCamant. All rights reserved.
+# Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved.
# This module is free software; you can redistribute and/or modify
# it under the same terms as Perl itself.
OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
SVf_IOK SVf_NOK SVf_ROK SVf_POK
+ CVf_METHOD CVf_LOCKED CVf_LVALUE
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = 0.59;
+$VERSION = 0.591;
use strict;
# Changes between 0.50 and 0.51:
walk_tree($op, sub {
my $op = shift;
if ($op->name eq "gv") {
+ my $gv = $self->gv_or_padgv($op);
if ($op->next->name eq "entersub") {
- next if $self->{'subs_done'}{$ {$op->gv}}++;
- next if class($op->gv->CV) eq "SPECIAL";
- $self->todo($op->gv, $op->gv->CV, 0);
- $self->walk_sub($op->gv->CV);
+ return if $self->{'subs_done'}{$$gv}++;
+ return if class($gv->CV) eq "SPECIAL";
+ $self->todo($gv, $gv->CV, 0);
+ $self->walk_sub($gv->CV);
} elsif ($op->next->name eq "enterwrite"
or ($op->next->name eq "rv2gv"
and $op->next->next->name eq "enterwrite")) {
- next if $self->{'forms_done'}{$ {$op->gv}}++;
- next if class($op->gv->FORM) eq "SPECIAL";
- $self->todo($op->gv, $op->gv->FORM, 1);
- $self->walk_sub($op->gv->FORM);
+ return if $self->{'forms_done'}{$$gv}++;
+ return if class($gv->FORM) eq "SPECIAL";
+ $self->todo($gv, $gv->FORM, 1);
+ $self->walk_sub($gv->FORM);
}
}
});
while (scalar(@{$self->{'subs_todo'}})) {
push @text, $self->next_todo;
}
- print indent(join("", @text)), "\n" if @text;
+ print $self->indent(join("", @text)), "\n" if @text;
}
}
if ($cv->FLAGS & SVf_POK) {
$proto = "(". $cv->PV . ") ";
}
+ 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;
+ }
+
local($self->{'curcv'}) = $cv;
local($self->{'curstash'}) = $self->{'curstash'};
if (not null $cv->ROOT) {
$op = $op->sibling; # skip nextstate
my @exprs;
$kid = $op->first->sibling; # skip pushmark
- push @text, $kid->sv->PV;
+ push @text, $self->const_sv($kid)->PV;
$kid = $kid->sibling;
for (; not null $kid; $kid = $kid->sibling) {
push @exprs, $self->deparse($kid, 0);
and $seq > $self->{'subs_todo'}[0][0]) {
push @text, $self->next_todo;
}
- my $stash = $op->stash->NAME;
+ my $stash = $op->stashpv;
if ($stash ne $self->{'curstash'}) {
push @text, "package $stash;\n";
$self->{'curstash'} = $stash;
}
if ($self->{'linenums'}) {
push @text, "\f#line " . $op->line .
- ' "' . substr($op->filegv->NAME, 2), qq'"\n';
+ ' "' . $op->file, qq'"\n';
}
return join("", @text);
}
sub pp_i_predec { pfixop(@_, "--", 23) }
sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
-sub pp_complement { maybe_targmy(@_. \&pfixop, "~", 21) }
+sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
sub pp_negate { maybe_targmy(@_, \&real_negate) }
sub real_negate {
if (class($op) eq "UNOP" and $op->first->name eq "const"
and $op->first->private & OPpCONST_BARE)
{
- my $name = $op->first->sv->PV;
+ my $name = $self->const_sv($op->first)->PV;
$name =~ s[/][::]g;
$name =~ s/\.pm//g;
return "require($name)";
sub padval {
my $self = shift;
my $targ = shift;
+ #cluck "curcv was undef" unless $self->{curcv};
return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
}
# 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 "GVOP") {
+ } elsif (class($op) eq "SVOP") {
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 deparse_binop_left {
my $self = shift;
my($op, $left, $prec) = @_;
- if ($left{assoc_class($op)}
+ if ($left{assoc_class($op)} && $left{assoc_class($left)}
and $left{assoc_class($op)} == $left{assoc_class($left)})
{
return $self->deparse($left, $prec - .00001);
sub deparse_binop_right {
my $self = shift;
my($op, $right, $prec) = @_;
- if ($right{assoc_class($op)}
+ if ($right{assoc_class($op)} && $right{assoc_class($right)}
and $right{assoc_class($op)} == $right{assoc_class($right)})
{
return $self->deparse($right, $prec - .00001);
my $fh;
if ($op->flags & OPf_SPECIAL) {
# $kid is an OP_CONST
- $fh = $kid->sv->PV;
+ $fh = $self->const_sv($kid)->PV;
} else {
$fh = $self->deparse($kid, 6);
$fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
}
}
+sub is_ifelse_cont {
+ my $op = shift;
+ return ($op->name eq "null" and class($op) eq "UNOP"
+ and $op->first->name =~ /^(and|cond_expr)$/
+ and is_scope($op->first->first->sibling));
+}
+
sub pp_cond_expr {
my $self = shift;
my($op, $cx) = @_;
my $true = $cond->sibling;
my $false = $true->sibling;
my $cuddle = $self->{'cuddle'};
- unless ($cx == 0 and is_scope($true) and is_scope($false)) {
+ unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
+ (is_scope($false) || is_ifelse_cont($false))) {
$cond = $self->deparse($cond, 8);
$true = $self->deparse($true, 8);
$false = $self->deparse($false, 8);
return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
- }
+ }
+
$cond = $self->deparse($cond, 1);
$true = $self->deparse($true, 0);
- if ($false->name eq "lineseq") { # braces w/o scope => elsif
- my $head = "if ($cond) {\n\t$true\n\b}";
- my @elsifs;
- while (!null($false) and $false->name eq "lineseq") {
- my $newop = $false->first->sibling->first;
- my $newcond = $newop->first;
- my $newtrue = $newcond->sibling;
- $false = $newtrue->sibling; # last in chain is OP_AND => no else
- $newcond = $self->deparse($newcond, 1);
- $newtrue = $self->deparse($newtrue, 0);
- push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
- }
- if (!null($false)) {
- $false = $cuddle . "else {\n\t" .
- $self->deparse($false, 0) . "\n\b}\cK";
- } else {
- $false = "\cK";
- }
- return $head . join($cuddle, "", @elsifs) . $false;
+ my $head = "if ($cond) {\n\t$true\n\b}";
+ my @elsifs;
+ while (!null($false) and is_ifelse_cont($false)) {
+ my $newop = $false->first;
+ my $newcond = $newop->first;
+ my $newtrue = $newcond->sibling;
+ $false = $newtrue->sibling; # last in chain is OP_AND => no else
+ $newcond = $self->deparse($newcond, 1);
+ $newtrue = $self->deparse($newtrue, 0);
+ push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
+ }
+ if (!null($false)) {
+ $false = $cuddle . "else {\n\t" .
+ $self->deparse($false, 0) . "\n\b}\cK";
+ } else {
+ $false = "\cK";
}
- $false = $self->deparse($false, 0);
- return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK";
+ return $head . join($cuddle, "", @elsifs) . $false;
}
sub pp_leaveloop {
if (is_state $state) {
$expr = $self->deparse($state, 0);
$state = $state->sibling;
- last if null $kid;
+ last if null $state;
}
$expr .= $self->deparse($state, 0);
push @exprs, $expr if $expr;
} elsif ($op->first->name eq "enter") {
return $self->pp_leave($op, $cx);
} elsif ($op->targ == OP_STRINGIFY) {
- return $self->dquote($op);
+ return $self->dquote($op, $cx);
} elsif (!null($op->first->sibling) and
$op->first->sibling->name eq "readline" and
$op->first->sibling->flags & OPf_STACKED) {
return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
}
+sub gv_or_padgv {
+ my $self = shift;
+ my $op = shift;
+ if (class($op) eq "PADOP") {
+ return $self->padval($op->padix);
+ } else { # class($op) eq "SVOP"
+ return $op->gv;
+ }
+}
+
sub pp_gvsv {
my $self = shift;
my($op, $cx) = @_;
- return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
+ my $gv = $self->gv_or_padgv($op);
+ return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv));
}
sub pp_gv {
my $self = shift;
my($op, $cx) = @_;
- return $self->gv_name($op->gv);
+ my $gv = $self->gv_or_padgv($op);
+ return $self->gv_name($gv);
}
sub pp_aelemfast {
my $self = shift;
my($op, $cx) = @_;
- my $gv = $op->gv;
+ my $gv = $self->gv_or_padgv($op);
return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
}
my($op, $cx) = @_;
my $kid = $op->first;
if ($kid->name eq "const") { # constant list
- my $av = $kid->sv;
+ my $av = $self->const_sv($kid);
return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
} else {
return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
}
$obj = $self->deparse($obj, 24);
if ($meth->name eq "method_named") {
- $meth = $meth->sv->PV;
+ $meth = $self->const_sv($meth)->PV;
} else {
$meth = $meth->first;
if ($meth->name eq "const") {
# As of 5.005_58, this case is probably obsoleted by the
# method_named case above
- $meth = $meth->sv->PV; # needs to be bare
+ $meth = $self->const_sv($meth)->PV; # needs to be bare
} else {
$meth = $self->deparse($meth, 1);
}
$amper = "&";
$kid = "{" . $self->deparse($kid, 0) . "}";
} elsif ($kid->first->name eq "gv") {
- my $gv = $kid->first->gv;
+ my $gv = $self->gv_or_padgv($kid->first);
if (class($gv->CV) ne "SPECIAL") {
$proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
}
} else {
if (defined $proto and $proto eq "") {
return $kid;
- } elsif ($proto eq "\$") {
+ } elsif (defined $proto and $proto eq "\$") {
return $self->maybe_parens_func($kid, $args, $cx, 16);
- } elsif ($proto or $simple) {
+ } elsif (defined($proto) && $proto or $simple) {
return $self->maybe_parens_func($kid, $args, $cx, 5);
} else {
return "$kid(" . $args . ")";
}
}
+sub const_sv {
+ my $self = shift;
+ my $op = shift;
+ my $sv = $op->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) = @_;
# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
-# return $op->sv->PV;
+# return $self->const_sv($op)->PV;
# }
- return const($op->sv);
+ my $sv = $self->const_sv($op);
+ return const($sv);
}
sub dq {
my $op = shift;
my $type = $op->name;
if ($type eq "const") {
- return uninterp(escape_str(unback($op->sv->PV)));
+ return uninterp(escape_str(unback($self->const_sv($op)->PV)));
} elsif ($type eq "concat") {
return $self->dq($op->first) . $self->dq($op->last);
} elsif ($type eq "uc") {
sub dquote {
my $self = shift;
- my($op, $cx) = shift;
+ my($op, $cx) = @_;
my $kid = $op->first->sibling; # skip ex-stringify, pushmark
return $self->deparse($kid, $cx) if $self->{'unquote'};
$self->maybe_targmy($kid, $cx,
sub collapse {
my(@chars) = @_;
- my($c, $str, $tr);
+ my($str, $c, $tr) = ("");
for ($c = 0; $c < @chars; $c++) {
$tr = $chars[$c];
$str .= pchr($tr);
}
@from = @newfrom;
}
- unless ($flags & OPpTRANS_DELETE) {
+ unless ($flags & OPpTRANS_DELETE || !@to) {
pop @to while $#to and $to[$#to] == $to[$#to -1];
}
my($from, $to);
my $op = shift;
my $type = $op->name;
if ($type eq "const") {
- return uninterp($op->sv->PV);
+ return uninterp($self->const_sv($op)->PV);
} elsif ($type eq "concat") {
return $self->re_dq($op->first) . $self->re_dq($op->last);
} elsif ($type eq "uc") {