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
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.73;
+$VERSION = 0.79;
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
$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'};
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();
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;
$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
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) = @_;
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;
+ return $self->anon_hash_or_list($op, $cx);
} elsif (!null($kid->sibling) and
$kid->sibling->name eq "anoncode") {
return "sub " .
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,
&& !($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 $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 $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);
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 $kid->pmflags & PMf_SKIPWHITE) {
+ $exprs[0] = "' '";
}
$expr = "split(" . join(", ", @exprs) . ")";
=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
https://perl5.git.perl.org / perl5.git / blobdiff