OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
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
+ OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
OPpSORT_REVERSE
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
CVf_METHOD CVf_LVALUE
($] < 5.008009 ? () : qw(OPpCONST_NOVER OPpPAD_STATE)),
($] < 5.009 ? 'PMf_SKIPWHITE' : qw(RXf_SKIPWHITE)),
($] < 5.011 ? 'CVf_LOCKED' : 'OPpREVERSE_INPLACE'),
- ($] < 5.013 ? () : 'PMf_NONDESTRUCT');
-$VERSION = "1.04";
+ ($] < 5.013 ? () : 'PMf_NONDESTRUCT'),
+ ($] < 5.015003 &&
+ # This empirical feature test is required during the
+ # transitional phase where blead still identifies itself
+ # as 5.15.2 but has had $[ removed. After blead has its
+ # version number bumped to 5.15.3, this can be reduced to
+ # just test $] < 5.015003.
+ ($] < 5.015002 || do { require B; exists(&B::OPpCONST_ARYBASE) })
+ ? qw(OPpCONST_ARYBASE) : ());
+$VERSION = "1.09";
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
# be to fake up a dummy constant that will never actually be true.
foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
OPpPAD_STATE RXf_SKIPWHITE CVf_LOCKED OPpREVERSE_INPLACE
- PMf_NONDESTRUCT)) {
+ PMf_NONDESTRUCT OPpCONST_ARYBASE)) {
no strict 'refs';
*{$_} = sub () {0} unless *{$_}{CODE};
}
#
# subs_declared
# keys are names of subs for which we've printed declarations.
-# That means we can omit parentheses from the arguments.
+# That means we can omit parentheses from the arguments. It also means we
+# need to put CORE:: on core functions of the same name.
#
# subs_deparsed
# Keeps track of fully qualified names of all deparsed subs.
else {
$pack =~ s/(::)?$/::/;
no strict 'refs';
- $stash = \%$pack;
+ $stash = \%{"main::$pack"};
}
my %stash = svref_2object($stash)->ARRAY;
while (my ($key, $val) = each %stash) {
}
elsif ($name eq '$[') {
- $arybase = $val;
+ if (OPpCONST_ARYBASE) {
+ $arybase = $val;
+ } else {
+ croak "\$[ can't be non-zero on this perl" unless $val == 0;
+ }
}
elsif ($name eq 'integer'
if ($name eq "umask" && $kid =~ /^\d+$/) {
$kid = sprintf("%#o", $kid);
}
- return "$name($kid)";
+ return $self->keyword($name) . "($kid)";
} else {
$kid = $self->deparse($kid, 16);
if ($name eq "umask" && $kid =~ /^\d+$/) {
$kid = sprintf("%#o", $kid);
}
+ $name = $self->keyword($name);
if (substr($kid, 0, 1) eq "\cS") {
# use kid's parens
return $name . substr($kid, 1);
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";
+ my $my = $op->private & OPpPAD_STATE
+ ? $self->keyword("state")
+ : "my";
if (want_scalar($op)) {
return "$my $text";
} else {
# If a lexical with the same name is in scope, it may need to be
# fully-qualified.
sub stash_variable {
- my ($self, $prefix, $name) = @_;
+ my ($self, $prefix, $name, $cx) = @_;
return "$prefix$name" if $name =~ /::/;
return "$prefix$name";
}
+ if ($name =~ /^[^\w+-]$/) {
+ if (defined $cx && $cx == 26) {
+ if ($prefix eq '@') {
+ return "$prefix\{$name}";
+ }
+ elsif ($name eq '#') { return '${#}' } # "${#}a" vs "$#a"
+ }
+ if ($prefix eq '$#') {
+ return "\$#{$name}";
+ }
+ }
+
my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
return "$prefix$name";
$self->{'curstash'} = $stash;
}
- if ($self->{'arybase'} != $op->arybase) {
+ if (OPpCONST_ARYBASE && $self->{'arybase'} != $op->arybase) {
push @text, '$[ = '. $op->arybase .";\n";
$self->{'arybase'} = $op->arybase;
}
sub pp_unstack { return "" } # see also leaveloop
+my %feature_keywords = (
+ # keyword => 'feature',
+ state => 'state',
+ say => 'say',
+ given => 'switch',
+ when => 'switch',
+ default => 'switch',
+ break => 'switch',
+);
+
+sub keyword {
+ my $self = shift;
+ my $name = shift;
+ return $name if $name =~ /^CORE::/; # just in case
+ if (exists $feature_keywords{$name}) {
+ return
+ $self->{'hinthash'}
+ && $self->{'hinthash'}{"feature_$feature_keywords{$name}"}
+ ? $name
+ : "CORE::$name";
+ }
+ if (
+ $name !~ /^(?:chom?p|exec|s(?:elect|ystem))\z/
+ && !defined eval{prototype "CORE::$name"}
+ ) { return $name }
+ if (
+ exists $self->{subs_declared}{$name}
+ or
+ exists &{"$self->{curstash}::$name"}
+ ) {
+ return "CORE::$name"
+ }
+ return $name;
+}
+
sub baseop {
my $self = shift;
my($op, $cx, $name) = @_;
- return $name;
+ return $self->keyword($name);
}
sub pp_stub {
my $self = shift;
my($op, $cx) = @_;
if ($cx <= 4) {
- $self->pfixop($op, $cx, "not ", 4);
+ $self->pfixop($op, $cx, $self->keyword("not")." ", 4);
} else {
$self->pfixop($op, $cx, "!", 21);
}
return $self->maybe_parens_unop($name, $kid, $cx);
} else {
- return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
+ return $self->keyword($name)
+ . ($op->flags & OPf_SPECIAL ? "()" : "");
}
}
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 pp_break { unop(@_, "break"); }
sub givwhen {
my $self = shift;
my $enterop = $op->first;
my ($head, $block);
if ($enterop->flags & OPf_SPECIAL) {
- $head = "default";
+ $head = $self->keyword("default");
$block = $self->deparse($enterop->first, 0);
}
else {
"\b}\cK";
}
-sub pp_leavegiven { givwhen(@_, "given"); }
-sub pp_leavewhen { givwhen(@_, "when"); }
+sub pp_leavegiven { givwhen(@_, $_[0]->keyword("given")); }
+sub pp_leavewhen { givwhen(@_, $_[0]->keyword("when")); }
sub pp_exists {
my $self = shift;
sub pp_next { loopex(@_, "next") }
sub pp_redo { loopex(@_, "redo") }
sub pp_goto { loopex(@_, "goto") }
-sub pp_dump { loopex(@_, "dump") }
+sub pp_dump { loopex(@_, $_[0]->keyword("dump")) }
sub ftst {
my $self = shift;
my(@exprs);
my $parens = ($cx >= 5) || $self->{'parens'};
my $kid = $op->first->sibling;
- return $name if null $kid;
+ return $self->keyword($name) if null $kid;
my $first;
$name = "socketpair" if $name eq "sockpair";
+ my $fullname = $self->keyword($name);
my $proto = prototype("CORE::$name");
if (defined $proto
&& $proto =~ /^;?\*/
push @exprs, $self->deparse($kid, 6);
}
if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) {
- return "$exprs[0] = $name" . ($parens ? "($exprs[0])" : " $exprs[0]");
+ return "$exprs[0] = $fullname"
+ . ($parens ? "($exprs[0])" : " $exprs[0]");
}
if ($parens) {
- return "$name(" . join(", ", @exprs) . ")";
+ return "$fullname(" . join(", ", @exprs) . ")";
} else {
- return "$name " . join(", ", @exprs);
+ return "$fullname " . join(", ", @exprs);
}
}
sub pp_glob {
my $self = shift;
my($op, $cx) = @_;
- if ($op->flags & OPf_SPECIAL) {
- return $self->deparse($op->first->sibling);
- }
my $text = $self->dq($op->first->sibling); # skip pushmark
if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
or $text =~ /[<>]/) {
$fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
}
my $len = $self->deparse($kid->sibling, 6);
+ my $name = $self->keyword('truncate');
if ($parens) {
- return "truncate($fh, $len)";
+ return "$name($fh, $len)";
} else {
- return "truncate $fh, $len";
+ return "$name $fh, $len";
}
}
$expr = $self->deparse($kid, 6);
push @exprs, $expr;
}
- my $name2 = $name;
+ my $name2;
if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
- $name2 = 'reverse sort';
+ $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort');
}
+ else { $name2 = $self->keyword($name) }
if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
return "$exprs[0] = $name2 $indir $exprs[0]";
}
return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
}
-BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
-BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
-BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
-BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
+BEGIN { for (qw[ const stringify rv2sv list glob ]) {
+ eval "sub OP_\U$_ () { " . opnumber($_) . "}"
+}}
sub pp_null {
my $self = shift;
return $self->pp_scope($op->first, $cx);
} elsif ($op->targ == OP_STRINGIFY) {
return $self->dquote($op, $cx);
+ } elsif ($op->targ == OP_GLOB) {
+ return $self->pp_glob(
+ $op->first # entersub
+ ->first # ex-list
+ ->first # pushmark
+ ->sibling, # glob
+ $cx
+ );
} elsif (!null($op->first->sibling) and
$op->first->sibling->name eq "readline" and
$op->first->sibling->flags & OPf_STACKED) {
my($op, $cx) = @_;
my $gv = $self->gv_or_padgv($op);
return $self->maybe_local($op, $cx, $self->stash_variable("\$",
- $self->gv_name($gv)));
+ $self->gv_name($gv), $cx));
}
sub pp_gv {
return $self->gv_name($gv);
}
+sub pp_aelemfast_lex {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $name = $self->padname($op->targ);
+ $name =~ s/^@/\$/;
+ return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
+}
+
sub pp_aelemfast {
my $self = shift;
my($op, $cx) = @_;
- my $name;
- if ($op->flags & OPf_SPECIAL) { # optimised PADAV
- $name = $self->padname($op->targ);
- $name =~ s/^@/\$/;
- }
- else {
- my $gv = $self->gv_or_padgv($op);
- $name = $self->gv_name($gv);
- $name = $self->{'curstash'}."::$name"
- if $name !~ /::/ && $self->lex_in_scope('@'.$name);
- $name = '$' . $name;
- }
+ # optimised PADAV, pre 5.15
+ return $self->pp_aelemfast_lex(@_) if ($op->flags & OPf_SPECIAL);
+ my $gv = $self->gv_or_padgv($op);
+ my $name = $self->gv_name($gv);
+ $name = $self->{'curstash'}."::$name"
+ if $name !~ /::/ && $self->lex_in_scope('@'.$name);
+ $name = '$' . $name;
return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
}
}
my $kid = $op->first;
if ($kid->name eq "gv") {
- return $self->stash_variable($type, $self->deparse($kid, 0));
+ return $self->stash_variable($type, $self->deparse($kid, 0), $cx);
} elsif (is_scalar $kid) {
my $str = $self->deparse($kid, 0);
if ($str =~ /^\$([^\w\d])\z/) {
} else {
$obj = $kid;
$kid = $kid->sibling;
- for (; !null ($kid->sibling) && $kid->name ne "method_named";
+ for (; !null ($kid->sibling) && $kid->name!~/^method(?:_named)?\z/;
$kid = $kid->sibling) {
push @exprs, $kid
}
} elsif (!ref($replroot) and $replroot > 0) {
$gv = $self->padval($replroot);
}
- $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv;
+ $ary = $self->stash_variable('@', $self->gv_name($gv), $cx) if $gv;
for (; !null($kid); $kid = $kid->sibling) {
push @exprs, $self->deparse($kid, 6);
=item $[
Takes a number, the value of the array base $[.
+Cannot be non-zero on Perl 5.15.3 or later.
=item bytes
=item *
-If a keyword is over-ridden, and your program explicitly calls
-the built-in version by using CORE::keyword, the output of B::Deparse
-will not reflect this. If you run the resulting code, it will call
-the over-ridden version rather than the built-in one. (Maybe there
-should be an option to B<always> print keyword calls as C<CORE::name>.)
-
-=item *
-
Some constants don't print correctly either with or without B<-d>.
For instance, neither B::Deparse nor Data::Dumper know how to print
dual-valued scalars correctly, as in:
https://perl5.git.perl.org / perl5.git / blobdiff