OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST
OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
- SVpad_TYPED
+ SVs_PADTMP 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
+ PADNAMEt_OUTER
MDEREF_reload
MDEREF_AV_pop_rv2av_aelem
MDEREF_AV_gvsv_vivify_rv2av_aelem
MDEREF_SHIFT
);
-$VERSION = '1.31';
+$VERSION = '1.38';
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 PMf_SKIPWHITE RXf_SKIPWHITE
- RXf_PMf_CHARSET RXf_PMf_KEEPCOPY
+ PMf_CHARSET PMf_KEEPCOPY PMf_NOCAPTURE CVf_ANONCONST
CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES
OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV
OPpLVREF_CV OPpLVREF_ELEM SVpad_STATE)) {
- eval { import B $_ };
+ eval { B->import($_) };
no strict 'refs';
*{$_} = sub () {0} unless *{$_}{CODE};
}
# lib/Tie/File/t/29_downcopy 5
# lib/vars 22
-# Object fields (were globals):
+# Object fields:
+#
+# in_coderef2text:
+# True when deparsing via $deparse->coderef2text; false when deparsing the
+# main program.
#
# avoid_local:
# (local($a), local($b)) and local($a, $b) have the same internal
# 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.
-#
# in_subst_repl
# True when deparsing the replacement part of a substitution.
#
sub todo {
my $self = shift;
my($cv, $is_form, $name) = @_;
- return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
+ my $cvfile = $cv->FILE//'';
+ return unless ($cvfile eq $0 || exists $self->{files}{$cvfile});
my $seq;
if ($cv->OUTSIDE_SEQ) {
$seq = $cv->OUTSIDE_SEQ;
$seq = 0;
}
push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form, $name];
- unless ($is_form || class($cv->STASH) eq 'SPECIAL') {
- $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1;
- }
}
sub next_todo {
my $self = shift;
my $ent = shift @{$self->{'subs_todo'}};
- my $cv = $ent->[1];
- if (ref $ent->[3]) { # lexical sub
- my @text;
+ my ($seq, $cv, $is_form, $name) = @$ent;
- # At this point, we may not yet have deparsed the hints that allow
- # lexical subroutines to be recognized. So adjust the current
- # hints and deparse them.
- # When lex subs cease being experimental, we should be able to
- # remove this code.
- {
- local $^H = $self->{'hints'};
- local %^H = %{ $self->{'hinthash'} || {} };
- local ${^WARNING_BITS} = $self->{'warnings'};
- feature->import("lexical_subs");
- warnings->unimport("experimental::lexical_subs");
- # Here we depend on the fact that individual features
- # will always set the feature bundle to ‘custom’
- # (== $feature::hint_mask). If we had another specific bundle
- # enabled previously, normalise it.
- if (($self->{'hints'} & $feature::hint_mask)
- != $feature::hint_mask)
- {
- if ($self->{'hinthash'}) {
- delete $self->{'hinthash'}{$_}
- for grep /^feature_/, keys %{$self->{'hinthash'}};
- }
- else { $self->{'hinthash'} = {} }
- $self->{'hinthash'}
- = _features_from_bundle(@$self{'hints','hinthash'});
- }
- push @text, $self->declare_hinthash($self->{'hinthash'}, \%^H,
- $self->{indent_size}, $^H);
- push @text, $self->declare_warnings($self->{'warnings'},
- ${^WARNING_BITS})
- unless ($self->{'warnings'} // 'u')
- eq (${^WARNING_BITS } // 'u');
- $self->{'warnings'} = ${^WARNING_BITS};
- $self->{'hints'} = $^H;
- $self->{'hinthash'} = {%^H};
- }
+ # any 'use strict; package foo' that should come before the sub
+ # declaration to sync with the first COP of the sub
+ my $pragmata = '';
+ if ($cv and !null($cv->START) and is_state($cv->START)) {
+ $pragmata = $self->pragmata($cv->START);
+ }
- # Now emit the sub itself.
- my $padname = $ent->[3];
- my $flags = $padname->FLAGS;
+ if (ref $name) { # lexical sub
+ # emit the sub.
+ my @text;
+ my $flags = $name->FLAGS;
push @text,
- !$cv || $ent->[0] <= $padname->COP_SEQ_RANGE_LOW
+ !$cv || $seq <= $name->COP_SEQ_RANGE_LOW
? $self->keyword($flags & SVpad_OUR
? "our"
: $flags & SVpad_STATE
# XXX We would do $self->keyword("sub"), but ‘my CORE::sub’
# doesn’t work and ‘my sub’ ignores a &sub in scope. I.e.,
# we have a core bug here.
- push @text, "sub " . substr $padname->PVX, 1;
+ push @text, "sub " . substr $name->PVX, 1;
if ($cv) {
# my sub foo { }
push @text, " " . $self->deparse_sub($cv);
# my sub foo;
push @text, ";\n";
}
- return join "", @text;
+ return $pragmata . join "", @text;
}
+
my $gv = $cv->GV;
- my $name = $ent->[3] // $self->gv_name($gv);
- if ($ent->[2]) {
- return $self->keyword("format") . " $name =\n"
- . $self->deparse_format($ent->[1]). "\n";
+ $name //= $self->gv_name($gv);
+ if ($is_form) {
+ return $pragmata . $self->keyword("format") . " $name =\n"
+ . $self->deparse_format($cv). "\n";
} else {
- $self->{'subs_declared'}{$name} = 1;
+ my $use_dec;
if ($name eq "BEGIN") {
- my $use_dec = $self->begin_is_use($cv);
+ $use_dec = $self->begin_is_use($cv);
if (defined ($use_dec) and $self->{'expand'} < 5) {
- return () if 0 == length($use_dec);
+ return $pragmata if 0 == length($use_dec);
$use_dec =~ s/^(use|no)\b/$self->keyword($1)/e;
- return $use_dec;
}
}
my $l = '';
$self->{'curstash'} = $stash;
}
}
+ if ($use_dec) {
+ return "$pragmata$p$l$use_dec";
+ }
if ( $name !~ /::/ and $self->lex_in_scope("&$name")
|| $self->lex_in_scope("&$name", 1) )
{
} elsif (defined $stash) {
$name =~ s/^\Q$stash\E::(?!\z|.*::)//;
}
- return "${p}${l}" . $self->keyword("sub") . " $name "
+ my $ret = "$pragmata${p}${l}" . $self->keyword("sub") . " $name "
. $self->deparse_sub($cv);
+ $self->{'subs_declared'}{$name} = 1;
+ return $ret;
}
}
+
# Return a "use" declaration for this BEGIN block, if appropriate
sub begin_is_use {
my ($self, $cv) = @_;
while (my ($key, $val) = each %stash) {
my $flags = $val->FLAGS;
if ($flags & SVf_ROK) {
- # A reference. Dump this if it is a reference to a CV.
- # But skip proxy constant subroutines, as some form of perl-
- # space visible code must have created them, be it a use
+ # A reference. Dump this if it is a reference to a CV. If it
+ # is a constant acting as a proxy for a full subroutine, then
+ # we may or may not have to dump it. If some form of perl-
+ # space visible code must have created it, be it a use
# statement, or some direct symbol-table manipulation code that
- # we will Deparse.
- if (class(my $cv = $val->RV) eq "CV") {
- $self->todo($cv, 0);
+ # we will deparse, then we don’t want to dump it. If it is the
+ # result of a declaration like sub f () { 42 } then we *do*
+ # want to dump it. The only way to distinguish these seems
+ # to be the SVs_PADTMP flag on the constant, which is admit-
+ # tedly a hack.
+ my $class = class(my $referent = $val->RV);
+ if ($class eq "CV") {
+ $self->todo($referent, 0);
+ } elsif (
+ $class !~ /^(AV|HV|CV|FM|IO|SPECIAL)\z/
+ # A more robust way to write that would be this, but B does
+ # not provide the SVt_ constants:
+ # ($referent->FLAGS & B::SVTYPEMASK) < B::SVt_PVAV
+ and $referent->FLAGS & SVs_PADTMP
+ ) {
+ push @{$self->{'protos_todo'}}, [$pack . $key, $val];
}
} elsif ($flags & (SVf_POK|SVf_IOK)) {
# Just a prototype. As an ugly but fairly effective way
my $ar;
my @ret;
foreach $ar (@{$self->{'protos_todo'}}) {
- my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
- push @ret, "sub " . $ar->[0] . "$proto;\n";
+ my $body = defined $ar->[1]
+ ? ref $ar->[1]
+ ? " () {\n " . $self->const($ar->[1]->RV,0) . ";\n}"
+ : " (". $ar->[1] . ");"
+ : ";";
+ push @ret, "sub " . $ar->[0] . "$body\n";
}
delete $self->{'protos_todo'};
return @ret;
croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
$self->init();
+ local $self->{in_coderef2text} = 1;
return $self->indent($self->deparse_sub(svref_2object($sub)));
}
my @names = $padlist->ARRAYelt(0)->ARRAY;
my @values = $padlist->ARRAYelt(1)->ARRAY;
my @todo;
+ PADENTRY:
for my $ix (0.. $#names) { for $_ ($names[$ix]) {
next if class($_) eq "SPECIAL";
my $name = $_->PVX;
if (defined $name && $name =~ /^&./) {
my $low = $_->COP_SEQ_RANGE_LOW;
my $flags = $_->FLAGS;
+ my $outer = $flags & PADNAMEt_OUTER;
if ($flags & SVpad_OUR) {
- push @todo, [$low, undef, 0, $_];
+ push @todo, [$low, undef, 0, $_]
# [seq, no cv, not format, padname]
+ unless $outer;
next;
}
my $protocv = $flags & SVpad_STATE
? $values[$ix]
: $_->PROTOCV;
+ if (class ($protocv) ne 'CV') {
+ my $flags = $flags;
+ my $cv = $cv;
+ my $name = $_;
+ while ($flags & PADNAMEt_OUTER && class ($protocv) ne 'CV')
+ {
+ $cv = $cv->OUTSIDE;
+ next PADENTRY if class($cv) eq 'SPECIAL'; # XXX freed?
+ my $padlist = $cv->PADLIST;
+ my $ix = $name->PARENT_PAD_INDEX;
+ $name = $padlist->NAMES->ARRAYelt($ix);
+ $flags = $name->FLAGS;
+ $protocv = $flags & SVpad_STATE
+ ? $padlist->ARRAYelt(1)->ARRAYelt($ix)
+ : $name->PROTOCV;
+ }
+ }
+ my $defined_in_this_sub = ${$protocv->OUTSIDE} == $$cv || do {
+ my $other = $protocv->PADLIST;
+ $$other && $other->outid == $padlist->id;
+ };
+ if ($flags & PADNAMEt_OUTER) {
+ next unless $defined_in_this_sub;
+ push @todo, [$protocv->OUTSIDE_SEQ, $protocv, 0, $_];
+ next;
+ }
my $outseq = $protocv->OUTSIDE_SEQ;
if ($outseq <= $low) {
# defined before its name is visible, so it’s gotta be
}
else {
# declared and defined separately: my sub f; sub f { ... }
- push @todo, [$low, undef, 0, $_],
- [$outseq, $protocv, 0, $_];
+ push @todo, [$low, undef, 0, $_];
+ push @todo, [$outseq, $protocv, 0, $_]
+ if $defined_in_this_sub;
}
}
}}
sub deparse_sub {
my $self = shift;
my $cv = shift;
- my $proto = "";
+ my @attrs;
+ my $protosig; # prototype or signature (what goes in the (....))
+
Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
local $self->{'curcop'} = $self->{'curcop'};
+
+ my $has_sig = $self->{hinthash}{feature_signatures};
if ($cv->FLAGS & SVf_POK) {
- $proto = "(". $cv->PV . ") ";
+ my $proto = $cv->PV;
+ if ($has_sig) {
+ push @attrs, "prototype($proto)";
+ }
+ else {
+ $protosig = $proto;
+ }
}
- 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;
+ if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ANONCONST)) {
+ push @attrs, "lvalue" if $cv->CvFLAGS & CVf_LVALUE;
+ push @attrs, "locked" if $cv->CvFLAGS & CVf_LOCKED;
+ push @attrs, "method" if $cv->CvFLAGS & CVf_METHOD;
+ push @attrs, "const" if $cv->CvFLAGS & CVf_ANONCONST;
}
local($self->{'curcv'}) = $cv;
push @ops, $o;
}
$body = $self->lineseq(undef, 0, @ops).";";
+ if ($ops[-1]->name =~ /^(next|db)state$/) {
+ # this handles void context in
+ # use feature signatures; sub ($=1) {}
+ $body .= "\n()";
+ }
my $scope_en = $self->find_scope_en($lineseq);
if (defined $scope_en) {
my $subs = join"", $self->seq_subs($scope_en);
else {
$body = $self->deparse($root->first, 0);
}
+ $body = "{\n\t$body\n\b}";
}
else {
my $sv = $cv->const_sv;
if ($$sv) {
# uh-oh. inlinable sub... format it differently
- return $proto . "{ " . $self->const($sv, 0) . " }\n";
+ $body = "{ " . $self->const($sv, 0) . " }\n";
} else { # XSUB? (or just a declaration)
- return "$proto;\n";
+ $body = ';'
}
}
- return $proto ."{\n\t$body\n\b}" ."\n";
+ $protosig = defined $protosig ? "($protosig) " : "";
+ my $attrs = '';
+ $attrs = ': ' . join('', map "$_ ", @attrs) if @attrs;
+ return "$protosig$attrs$body\n";
}
sub deparse_format {
my $need_parens = !$forbid_parens && $self->{'in_refgen'}
&& $op->name =~ /[ah]v\z/
&& ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
+ # The @a in \my @a must not have parens.
+ if (!$need_parens && $self->{'in_refgen'}) {
+ $forbid_parens = 1;
+ }
if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
# Check $padname->FLAGS for statehood, rather than $op->private,
# because enteriter ops do not carry the flag.
return "$prefix$name";
}
- if ($name =~ /^[^\w+-]$/) {
+ if ($name =~ /^[^[:alpha:]_+-]$/) {
if (defined $cx && $cx == 26) {
if ($prefix eq '@') {
return "$prefix\{$name}";
return $prefix . $self->maybe_qualify($prefix, $name);
}
+my %unctrl = # portable to EBCDIC
+ (
+ "\c@" => '@', # unused
+ "\cA" => 'A',
+ "\cB" => 'B',
+ "\cC" => 'C',
+ "\cD" => 'D',
+ "\cE" => 'E',
+ "\cF" => 'F',
+ "\cG" => 'G',
+ "\cH" => 'H',
+ "\cI" => 'I',
+ "\cJ" => 'J',
+ "\cK" => 'K',
+ "\cL" => 'L',
+ "\cM" => 'M',
+ "\cN" => 'N',
+ "\cO" => 'O',
+ "\cP" => 'P',
+ "\cQ" => 'Q',
+ "\cR" => 'R',
+ "\cS" => 'S',
+ "\cT" => 'T',
+ "\cU" => 'U',
+ "\cV" => 'V',
+ "\cW" => 'W',
+ "\cX" => 'X',
+ "\cY" => 'Y',
+ "\cZ" => 'Z',
+ "\c[" => '[', # unused
+ "\c\\" => '\\', # unused
+ "\c]" => ']', # unused
+ "\c_" => '_', # unused
+ );
+
# Return just the name, without the prefix. It may be returned as a quoted
# string. The second return value is a boolean indicating that.
sub stash_variable_name {
my $name = $self->gv_name($gv, 1);
$name = $self->maybe_qualify($prefix,$name);
if ($name =~ /^(?:\S|(?!\d)[\ca-\cz]?(?:\w|::)*|\d+)\z/) {
- $name =~ s/^([\ca-\cz])/'^'.($1|'@')/e;
+ $name =~ s/^([\ca-\cz])/'^' . $unctrl{$1}/e;
$name =~ /^(\^..|{)/ and $name = "{$name}";
return $name, 0; # not quoted
}
return $hh;
}
-# Notice how subs and formats are inserted between statements here;
-# also $[ assignments and pragmas.
-sub pp_nextstate {
+# generate any pragmas, 'package foo' etc needed to synchronise
+# with the given cop
+
+sub pragmata {
my $self = shift;
- my($op, $cx) = @_;
- $self->{'curcop'} = $op;
+ my($op) = @_;
+
my @text;
- push @text, $self->cop_subs($op);
- if (@text) {
- # Special marker to swallow up the semicolon
- push @text, "\cK";
- }
+
my $stash = $op->stashpv;
if ($stash ne $self->{'curstash'}) {
push @text, $self->keyword("package") . " $stash;\n";
$feature::hint_bundles[$to >> $feature::hint_shift];
$bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12
push @text,
- $self->keyword("no") . " feature;\n",
+ $self->keyword("no") . " feature ':all';\n",
$self->keyword("use") . " feature ':$bundle';\n";
}
}
$self->{'hinthash'} = $newhh;
}
+ return join("", @text);
+}
+
+
+# Notice how subs and formats are inserted between statements here;
+# also $[ assignments and pragmas.
+sub pp_nextstate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ $self->{'curcop'} = $op;
+
+ my @text;
+
+ my @subs = $self->cop_subs($op);
+ if (@subs) {
+ # Special marker to swallow up the semicolon
+ push @subs, "\cK";
+ }
+ push @text, @subs;
+
+ push @text, $self->pragmata($op);
+
+
# This should go after of any branches that add statements, to
# increase the chances that it refers to the same line it did in
# the original program.
elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
return $self->keyword("no") . " warnings;\n";
}
- return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n\cK";
+ return "BEGIN {\${^WARNING_BITS} = \""
+ . join("", map { sprintf("\\x%02x", ord $_) } split "", $to)
+ . "\"}\n\cK";
}
sub declare_hints {
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) }
+*pp_ncomplement = *pp_complement;
+sub pp_scomplement { maybe_targmy(@_, \&pfixop, "~.", 21) }
sub pp_negate { maybe_targmy(@_, \&real_negate) }
sub real_negate {
my $builtinname = $name;
$builtinname =~ /^CORE::/ or $builtinname = "CORE::$name";
if (defined prototype($builtinname)
+ && $builtinname ne 'CORE::readline'
&& prototype($builtinname) =~ /^;?\*/
&& $kid->name eq "rv2gv") {
$kid = $kid->first;
sub pp_getsockname { unop(@_, "getsockname") }
sub pp_getpeername { unop(@_, "getpeername") }
-sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
+sub pp_chdir {
+ my ($self, $op, $cx) = @_;
+ if (($op->flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS)) {
+ my $kw = $self->keyword("chdir");
+ my $kid = $self->const_sv($op->first)->PV;
+ my $code = $kw
+ . ($cx >= 16 || $self->{'parens'} ? "($kid)" : " $kid");
+ maybe_targmy(@_, sub { $_[3] }, $code);
+ } else {
+ maybe_targmy(@_, \&unop, "chdir")
+ }
+}
+
sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
sub pp_readlink { unop(@_, "readlink") }
sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
my $self = shift;
my($op, $cx) = @_;
my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
- if (class($op) eq "UNOP" and $op->first->name eq "const"
- and $op->first->private & OPpCONST_BARE)
- {
- my $name = $self->const_sv($op->first)->PV;
- $name =~ s[/][::]g;
- $name =~ s/\.pm//g;
- return $self->maybe_parens("$opname $name", $cx, 16);
- } else {
- $self->unop(
+ my $kid = $op->first;
+ if ($kid->name eq 'const') {
+ my $priv = $kid->private;
+ my $sv = $self->const_sv($kid);
+ my $arg;
+ if ($priv & OPpCONST_BARE) {
+ $arg = $sv->PV;
+ $arg =~ s[/][::]g;
+ $arg =~ s/\.pm//g;
+ } elsif ($priv & OPpCONST_NOVER) {
+ $opname = $self->keyword('no');
+ $arg = $self->const($sv, 16);
+ } elsif ((my $tmp = $self->const($sv, 16)) =~ /^v/) {
+ $arg = $tmp;
+ }
+ if ($arg) {
+ return $self->maybe_parens("$opname $arg", $cx, 16);
+ }
+ }
+ $self->unop(
$op, $cx,
- $op->first->name eq 'const'
- && $op->first->private & OPpCONST_NOVER
- ? "no"
- : $opname,
+ $opname,
1, # llafr does not apply
- );
- }
+ );
}
sub pp_scalar {
my $kid = $op->first;
if ($kid->name eq "null") {
my $anoncode = $kid = $kid->first;
+ if ($anoncode->name eq "anonconst") {
+ $anoncode = $anoncode->first->first->sibling;
+ }
if ($anoncode->name eq "anoncode"
or !null($anoncode = $kid->sibling) and
$anoncode->name eq "anoncode") {
my $self = shift;
my($op, $cx) = @_;
my $kid = $op->first;
- $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
- return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
+ if (is_scalar($kid)
+ and $op->flags & OPf_SPECIAL
+ and $self->deparse($kid, 1) eq 'ARGV')
+ {
+ return '<<>>';
+ }
return $self->unop($op, $cx, "readline");
}
'subtract' => 18, 'i_subtract' => 18,
'concat' => 18,
'left_shift' => 17, 'right_shift' => 17,
- 'bit_and' => 13,
+ 'bit_and' => 13, 'nbit_and' => 13, 'sbit_and' => 13,
'bit_or' => 12, 'bit_xor' => 12,
+ 'sbit_or' => 12, 'sbit_xor' => 12,
+ 'nbit_or' => 12, 'nbit_xor' => 12,
'and' => 3,
'or' => 2, 'xor' => 2,
);
'subtract=' => 7, 'i_subtract=' => 7,
'concat=' => 7,
'left_shift=' => 7, 'right_shift=' => 7,
- 'bit_and=' => 7,
- 'bit_or=' => 7, 'bit_xor=' => 7,
+ 'bit_and=' => 7, 'sbit_and=' => 7, 'nbit_and=' => 7,
+ 'nbit_or=' => 7, 'nbit_xor=' => 7,
+ 'sbit_or=' => 7, 'sbit_xor=' => 7,
'andassign' => 7,
'orassign' => 7,
);
sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
+*pp_nbit_and = *pp_bit_and;
+*pp_nbit_or = *pp_bit_or;
+*pp_nbit_xor = *pp_bit_xor;
+sub pp_sbit_and { maybe_targmy(@_, \&binop, "&.", 13, ASSIGN) }
+sub pp_sbit_or { maybe_targmy(@_, \&binop, "|.", 12, ASSIGN) }
+sub pp_sbit_xor { maybe_targmy(@_, \&binop, "^.", 12, ASSIGN) }
sub pp_eq { binop(@_, "==", 14) }
sub pp_ne { binop(@_, "!=", 14) }
sub pp_i_gt { binop(@_, ">", 15) }
sub pp_i_ge { binop(@_, ">=", 15) }
sub pp_i_le { binop(@_, "<=", 15) }
-sub pp_i_ncmp { binop(@_, "<=>", 14) }
+sub pp_i_ncmp { maybe_targmy(@_, \&binop, "<=>", 14) }
sub pp_seq { binop(@_, "eq", 14) }
sub pp_sne { binop(@_, "ne", 14) }
sub pp_sgt { binop(@_, "gt", 15) }
sub pp_sge { binop(@_, "ge", 15) }
sub pp_sle { binop(@_, "le", 15) }
-sub pp_scmp { binop(@_, "cmp", 14) }
+sub pp_scmp { maybe_targmy(@_, \&binop, "cmp", 14) }
sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
return "$exprs[0] = $fullname"
. ($parens ? "($exprs[0])" : " $exprs[0]");
}
- if ($name =~ /^(system|exec)$/
- && ($op->flags & OPf_STACKED)
- && @exprs > 1)
- {
- # handle the "system prog a1,a2,.." form
- my $prog = shift @exprs;
- $exprs[0] = "$prog $exprs[0]";
- }
if ($parens && $nollafr) {
return "($fullname " . join(", ", @exprs) . ")";
sub pp_open_dir { listop(@_, "opendir") }
sub pp_seekdir { listop(@_, "seekdir") }
sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
-sub pp_system { maybe_targmy(@_, \&listop, "system") }
-sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
+sub pp_system { maybe_targmy(@_, \&indirop, "system") }
+sub pp_exec { maybe_targmy(@_, \&indirop, "exec") }
sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
my $kid = $op->first->sibling; # skip pushmark
my $keyword =
$op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
- my $text;
- if ($keyword =~ /^CORE::/
- or $kid->name ne 'const'
- or ($text = $self->dq($kid))
- =~ /^\$?(\w|::|\`)+$/ # could look like a readline
- or $text =~ /[<>]/) {
- $text = $self->deparse($kid);
- return $cx >= 5 || $self->{'parens'}
- ? "$keyword($text)"
- : "$keyword $text";
- } else {
- return '<' . $text . '>';
- }
+ my $text = $self->deparse($kid);
+ return $cx >= 5 || $self->{'parens'}
+ ? "$keyword($text)"
+ : "$keyword $text";
}
# Truncate is special because OPf_SPECIAL makes a bareword first arg
# comparison routine. We have to say sort(...) in that case.
return "$name2($args)";
} else {
- return $self->maybe_parens_func($name2, $args, $cx, 5);
+ return length $args
+ ? $self->maybe_parens_func($name2, $args, $cx, 5)
+ : $name2 . '()' x (7 < $cx);
}
}
if ($op->first && ($op->first->flags & OPf_KIDS)) {
# arbitrary initial expression, e.g. f(1,2,3)->[...]
- $text .= $self->deparse($op->first, 24);
+ my $expr = $self->deparse($op->first, 24);
+ # stop "exists (expr)->{...}" being interpreted as
+ #"(exists (expr))->{...}"
+ $expr = "+$expr" if $expr =~ /^\(/;
+ $text .= $expr;
}
my @items = $op->aux_list($self->{curcv});
1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
$proto =~ s/^\s*//;
while ($proto) {
- $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)\s*//;
+ $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;|)\s*//;
my $chr = $1;
if ($chr eq "") {
return "&" if @args;
|divide|i_divide|modulo|i_modulo|add|i_add|subtract
|i_subtract|concat|stringify|left_shift|right_shift|lt
|i_lt|gt|i_gt|le|i_le|ge|i_ge|eq|i_eq|ne|i_ne|ncmp|i_ncmp
- |slt|sgt|sle|sge|seq|sne|scmp|bit_and|bit_xor|bit_or
- |negate|i_negate|not|complement|smartmatch|atan2|sin|cos
+ |slt|sgt|sle|sge|seq|sne|scmp|[sn]?bit_(?:and|x?or)|negate
+ |i_negate|not|[sn]?complement|smartmatch|atan2|sin|cos
|rand|srand|exp|log|sqrt|int|hex|oct|abs|length|substr
|vec|index|rindex|sprintf|formline|ord|chr|crypt|ucfirst
|lcfirst|uc|lc|quotemeta|aelemfast|aelem|exists|helem
}
my $simple = 0;
my $proto = undef;
+ my $lexical;
if (is_scope($kid)) {
$amper = "&";
$kid = "{" . $self->deparse($kid, 0) . "}";
$kid = $self->deparse($kid, 24);
} else {
$prefix = "";
- my $arrow = is_subscriptable($kid->first) || $kid->first->name eq "padcv" ? "" : "->";
+ my $grandkid = $kid->first;
+ my $arrow = ($lexical = $grandkid->name eq "padcv")
+ || is_subscriptable($grandkid)
+ ? ""
+ : "->";
$kid = $self->deparse($kid, 24) . $arrow;
+ if ($lexical) {
+ my $padlist = $self->{'curcv'}->PADLIST;
+ my $padoff = $grandkid->targ;
+ my $padname = $padlist->ARRAYelt(0)->ARRAYelt($padoff);
+ my $protocv = $padname->FLAGS & SVpad_STATE
+ ? $padlist->ARRAYelt(1)->ARRAYelt($padoff)
+ : $padname->PROTOCV;
+ if ($protocv->FLAGS & SVf_POK) {
+ $proto = $protocv->PV
+ }
+ $simple = 1;
+ }
}
# Doesn't matter how many prototypes there are, if
# they haven't happened yet!
- my $declared;
- {
+ my $declared = $lexical || exists $self->{'subs_declared'}{$kid};
+ if (not $declared and $self->{'in_coderef2text'}) {
no strict 'refs';
no warnings 'uninitialized';
- $declared = exists $self->{'subs_declared'}{$kid}
- || (
+ $declared =
+ (
defined &{ ${$self->{'curstash'}."::"}{$kid} }
&& !exists
$self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
&& defined prototype $self->{'curstash'}."::".$kid
);
- if (!$declared && defined($proto)) {
- # Avoid "too early to check prototype" warning
- ($amper, $proto) = ('&');
- }
+ }
+ if (!$declared && defined($proto)) {
+ # Avoid "too early to check prototype" warning
+ ($amper, $proto) = ('&');
}
my $args;
$kid =~ s/^CORE::GLOBAL:://;
my $dproto = defined($proto) ? $proto : "undefined";
+ my $scalar_proto = $dproto =~ /^;*(?:[\$*_+]|\\.|\\\[[^]]\])\z/;
if (!$declared) {
return "$kid(" . $args . ")";
} elsif ($dproto =~ /^\s*\z/) {
return $kid;
- } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
+ } elsif ($scalar_proto and is_scalar($exprs[0])) {
# is_scalar is an excessively conservative test here:
# really, we should be comparing to the precedence of the
# top operator of $exprs[0] (ala unop()), but that would
# take some major code restructuring to do right.
return $self->maybe_parens_func($kid, $args, $cx, 16);
- } elsif ($dproto ne '$' and defined($proto) || $simple) { #'
+ } elsif (not $scalar_proto and defined($proto) || $simple) { #'
return $self->maybe_parens_func($kid, $args, $cx, 5);
} else {
return "$kid(" . $args . ")";
}
}
-my %unctrl = # portable to EBCDIC
- (
- "\c@" => '\c@', # unused
- "\cA" => '\cA',
- "\cB" => '\cB',
- "\cC" => '\cC',
- "\cD" => '\cD',
- "\cE" => '\cE',
- "\cF" => '\cF',
- "\cG" => '\cG',
- "\cH" => '\cH',
- "\cI" => '\cI',
- "\cJ" => '\cJ',
- "\cK" => '\cK',
- "\cL" => '\cL',
- "\cM" => '\cM',
- "\cN" => '\cN',
- "\cO" => '\cO',
- "\cP" => '\cP',
- "\cQ" => '\cQ',
- "\cR" => '\cR',
- "\cS" => '\cS',
- "\cT" => '\cT',
- "\cU" => '\cU',
- "\cV" => '\cV',
- "\cW" => '\cW',
- "\cX" => '\cX',
- "\cY" => '\cY',
- "\cZ" => '\cZ',
- "\c[" => '\c[', # unused
- "\c\\" => '\c\\', # unused
- "\c]" => '\c]', # unused
- "\c_" => '\c_', # unused
- );
-
# character escapes, but not delimiters that might need to be escaped
sub escape_str { # ASCII, UTF8
my($str) = @_;
$str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
$str =~ s/\a/\\a/g;
-# $str =~ s/\cH/\\b/g; # \b means something different in a regex
+# $str =~ s/\cH/\\b/g; # \b means something different in a regex; and \cH
+ # isn't a backspace in EBCDIC
$str =~ s/\t/\\t/g;
$str =~ s/\n/\\n/g;
$str =~ s/\e/\\e/g;
$str =~ s/\f/\\f/g;
$str =~ s/\r/\\r/g;
- $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
- $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
+ $str =~ s/([\cA-\cZ])/'\\c' . $unctrl{$1}/ge;
+ $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/age;
return $str;
}
my($str) = @_;
$str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
$str =~ s/([[:^print:]])/
- ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
+ ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/age;
$str =~ s/\n/\n\f/g;
return $str;
}
return $str;
} elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
my $ref = $sv->RV;
- if (class($ref) eq "AV") {
+ my $class = class($ref);
+ if ($class eq "AV") {
return "[" . $self->list_const(2, $ref->ARRAY) . "]";
- } elsif (class($ref) eq "HV") {
+ } elsif ($class eq "HV") {
my %hash = $ref->ARRAY;
my @elts;
for my $k (sort keys %hash) {
push @elts, "$k => " . $self->const($hash{$k}, 6);
}
return "{" . join(", ", @elts) . "}";
- } elsif (class($ref) eq "CV") {
+ } elsif ($class eq "CV") {
BEGIN {
if ($] > 5.0150051) {
require overloading;
}
return "sub " . $self->deparse_sub($ref);
}
- if ($ref->FLAGS & SVs_SMG) {
+ if ($class ne 'SPECIAL' and $ref->FLAGS & SVs_SMG) {
for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
if ($mg->TYPE eq 'r') {
my $re = re_uninterp(escape_re(re_unback($mg->precomp)));
return '\\\\';
} elsif ($n == ord "-") {
return "\\-";
- } elsif ($n >= ord(' ') and $n <= ord('~')) {
+ } elsif (utf8::native_to_unicode($n) >= utf8::native_to_unicode(ord(' '))
+ and utf8::native_to_unicode($n) <= utf8::native_to_unicode(ord('~')))
+ {
+ # I'm presuming a regex is not ok here, otherwise we could have used
+ # /[[:print:]]/a to get here
return chr($n);
} elsif ($n == ord "\a") {
return '\\a';
} elsif ($n == ord "\r") {
return '\\r';
} elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
- return '\\c' . chr(ord("@") + $n);
+ return '\\c' . unctrl{chr $n};
} else {
# return '\x' . sprintf("%02x", $n);
return '\\' . sprintf("%03o", $n);
return $self->deparse($op->last, 26); # was join($", @ary)
} else {
my $ret = $self->deparse($op, 26);
- $ret =~ s/^\$([(|)])\z/\${$1}/; # $( $| $) need braces
+ $ret =~ s/^\$([(|)])\z/\${$1}/ # $( $| $) need braces
+ or $ret =~ s/^\@([-+])\z/\@{$1}/; # @- @+ need braces
return $ret;
}
}
my $kid = $op->first;
$kid = $kid->first if $kid->name eq "regcmaybe";
$kid = $kid->first if $kid->name eq "regcreset";
- if ($kid->name eq "null" and !null($kid->first)
+ my $kname = $kid->name;
+ if ($kname eq "null" and !null($kid->first)
and $kid->first->name eq 'pushmark')
{
my $str = '';
return $str, 1;
}
- return ($self->re_dq($kid), 1) if $self->pure_string($kid);
+ return ($self->re_dq($kid), 1)
+ if $kname =~ /^(?:rv2|pad)av/ or $self->pure_string($kid);
return ($self->deparse($kid, $cx), 0);
}
my ($self, $op) = @_;
my $flags = '';
my $pmflags = $op->pmflags;
+ if (!$pmflags) {
+ my $re = $op->pmregexp;
+ if ($$re) {
+ $pmflags = $re->compflags;
+ }
+ }
$flags .= "g" if $pmflags & PMf_GLOBAL;
$flags .= "i" if $pmflags & PMf_FOLD;
$flags .= "m" if $pmflags & PMf_MULTILINE;
$flags .= "s" if $pmflags & PMf_SINGLELINE;
$flags .= "x" if $pmflags & PMf_EXTENDED;
$flags .= "x" if $pmflags & PMf_EXTENDED_MORE;
- $flags .= "p" if $pmflags & RXf_PMf_KEEPCOPY;
- if (my $charset = $pmflags & RXf_PMf_CHARSET) {
+ $flags .= "p" if $pmflags & PMf_KEEPCOPY;
+ $flags .= "n" if $pmflags & PMf_NOCAPTURE;
+ if (my $charset = $pmflags & PMf_CHARSET) {
# Hardcoding this is fragile, but B does not yet export the
# constants we need.
- $flags .= qw(d l u a aa)[$charset >> 6]
+ $flags .= qw(d l u a aa)[$charset >> 7]
}
# The /d flag is indicated by 0; only show it if necessary.
elsif ($self->{hinthash} and
or $self->{hints} & $feature::hint_mask
&& ($self->{hints} & $feature::hint_mask)
!= $feature::hint_mask
- && do {
- $self->{hints} & $feature::hint_uni8bit;
- }
- ) {
+ && $self->{hints} & $feature::hint_uni8bit
+ ) {
$flags .= 'd';
}
$flags;
my %matchwords;
map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
- 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
+ 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi', 'soup', 'soupmix');
# When deparsing a regular expression with code blocks, we have to look in
# various places to find the blocks.
: &pp_padsv) . ')'
}
+
+sub pp_argcheck {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my ($params, $opt_params, $slurpy) = $op->aux_list($self->{curcv});
+ my $mandatory = $params - $opt_params;
+ my $check = '';
+
+ $check .= <<EOF if !$slurpy;
+die sprintf("Too many arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ <= $params;
+EOF
+
+ $check .= <<EOF if $mandatory > 0;
+die sprintf("Too few arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ >= $mandatory;
+EOF
+
+ my $cond = ($params & 1) ? 'unless' : 'if';
+ $check .= <<EOF if $slurpy eq '%';
+die sprintf("Odd name/value argument for subroutine at %s line %d.\\n", (caller)[1, 2]) if \@_ > $params && ((\@_ - $params) & 1);
+EOF
+
+ $check =~ s/;\n\z//;
+ return $check;
+}
+
+
+sub pp_argelem {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $var = $self->padname($op->targ);
+ my $ix = $op->string($self->{curcv});
+ my $expr;
+ if ($op->flags & OPf_KIDS) {
+ $expr = $self->deparse($op->first, 7);
+ }
+ elsif ($var =~ /^[@%]/) {
+ $expr = $ix ? "\@_[$ix .. \$#_]" : '@_';
+ }
+ else {
+ $expr = "\$_[$ix]";
+ }
+ return "my $var = $expr";
+}
+
+
+sub pp_argdefelem {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $ix = $op->targ;
+ my $expr = "\@_ >= " . ($ix+1) . " ? \$_[$ix] : ";
+ $expr .= $self->deparse($op->first, $cx);
+ return $expr;
+}
+
+
1;
__END__
=item *
Lexical (my) variables declared in scopes external to a subroutine
-appear in code2ref output text as package variables. This is a tricky
+appear in coderef2text output text as package variables. This is a tricky
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.
https://perl5.git.perl.org / perl5.git / blobdiff