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_PARENS
- OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
+ OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpKVSLICE
+ OPpCONST_BARE
OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST
- OPpSORT_REVERSE
+ OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE
+ OPpSPLIT_ASSIGN OPpSPLIT_LEX
+ OPpPADHV_ISKEYS OPpRV2HV_ISKEYS
+ OPpMULTICONCAT_APPEND OPpMULTICONCAT_STRINGIFY OPpMULTICONCAT_FAKE
+ OPpTRUEBOOL OPpINDEX_BOOLNEG
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);
-$VERSION = '1.31';
+ 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_AV_padsv_vivify_rv2av_aelem
+ MDEREF_AV_vivify_rv2av_aelem
+ MDEREF_AV_padav_aelem
+ MDEREF_AV_gvav_aelem
+ MDEREF_HV_pop_rv2hv_helem
+ MDEREF_HV_gvsv_vivify_rv2hv_helem
+ MDEREF_HV_padsv_vivify_rv2hv_helem
+ MDEREF_HV_vivify_rv2hv_helem
+ MDEREF_HV_padhv_helem
+ MDEREF_HV_gvhv_helem
+ MDEREF_ACTION_MASK
+ MDEREF_INDEX_none
+ MDEREF_INDEX_const
+ MDEREF_INDEX_padsv
+ MDEREF_INDEX_gvsv
+ MDEREF_INDEX_MASK
+ MDEREF_FLAG_last
+ MDEREF_MASK
+ MDEREF_SHIFT
+ );
+
+$VERSION = '1.46';
use strict;
-use vars qw/$AUTOLOAD/;
+our $AUTOLOAD;
use warnings ();
require feature;
# 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};
}
}
-# Changes between 0.50 and 0.51:
-# - fixed nulled leave with live enter in sort { }
-# - fixed reference constants (\"str")
-# - handle empty programs gracefully
-# - handle infinite loops (for (;;) {}, while (1) {})
-# - differentiate between 'for my $x ...' and 'my $x; for $x ...'
-# - various minor cleanups
-# - moved globals into an object
-# - added '-u', like B::C
-# - package declarations using cop_stash
-# - subs, formats and code sorted by cop_seq
-# Changes between 0.51 and 0.52:
-# - added pp_threadsv (special variables under USE_5005THREADS)
-# - added documentation
-# Changes between 0.52 and 0.53:
-# - many changes adding precedence contexts and associativity
-# - added '-p' and '-s' output style options
-# - various other minor fixes
-# Changes between 0.53 and 0.54:
-# - added support for new 'for (1..100)' optimization,
-# thanks to Gisle Aas
-# Changes between 0.54 and 0.55:
-# - added support for new qr// construct
-# - added support for new pp_regcreset OP
-# Changes between 0.55 and 0.56:
-# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
-# - fixed $# on non-lexicals broken in last big rewrite
-# - added temporary fix for change in opcode of OP_STRINGIFY
-# - fixed problem in 0.54's for() patch in 'for (@ary)'
-# - fixed precedence in conditional of ?:
-# - tweaked list paren elimination in 'my($x) = @_'
-# - made continue-block detection trickier wrt. null ops
-# - fixed various prototype problems in pp_entersub
-# - added support for sub prototypes that never get GVs
-# - added unquoting for special filehandle first arg in truncate
-# - print doubled rv2gv (a bug) as '*{*GV}' instead of illegal '**GV'
-# - added semicolons at the ends of blocks
-# - added -l '#line' declaration option -- fixes cmd/subval.t 27,28
-# Changes between 0.56 and 0.561:
-# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
-# - used new B.pm symbolic constants (done by Nick Ing-Simmons)
-# Changes between 0.561 and 0.57:
-# - stylistic changes to symbolic constant stuff
-# - handled scope in s///e replacement code
-# - added unquote option for expanding "" into concats, etc.
-# - split method and proto parts of pp_entersub into separate functions
-# - various minor cleanups
-# Changes after 0.57:
-# - added parens in \&foo (patch by Albert Dvornik)
-# Changes between 0.57 and 0.58:
-# - fixed '0' statements that weren't being printed
-# - added methods for use from other programs
-# (based on patches from James Duncan and Hugo van der Sanden)
-# - added -si and -sT to control indenting (also based on a patch from Hugo)
-# - added -sv to print something else instead of '???'
-# - preliminary version of utf8 tr/// handling
-# Changes after 0.58:
-# - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
-# - added support for Hugo's new OP_SETSTATE (like nextstate)
-# Changes between 0.58 and 0.59
-# - added support for Chip's OP_METHOD_NAMED
-# - added support for Ilya's OPpTARGET_MY optimization
-# - elided arrows before '()' subscripts when possible
-# Changes between 0.59 and 0.60
-# - support for method attributes was added
-# - some warnings fixed
-# - separate recognition of constant subs
-# - rewrote continue block handling, now recognizing for loops
-# - added more control of expanding control structures
-# Changes between 0.60 and 0.61 (mostly by Robin Houston)
-# - many bug-fixes
-# - support for pragmas and 'use'
-# - support for the little-used $[ variable
-# - support for __DATA__ sections
-# - UTF8 support
-# - BEGIN, CHECK, INIT and END blocks
-# - scoping of subroutine declarations fixed
-# - compile-time output from the input program can be suppressed, so that the
-# output is just the deparsed code. (a change to O.pm in fact)
-# - our() declarations
-# - *all* the known bugs are now listed in the BUGS section
-# - comprehensive test mechanism (TEST -deparse)
-# Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
-# - bug-fixes
-# - new switch -P
-# - support for command-line switches (-l, -0, etc.)
-# Changes between 0.63 and 0.64
-# - support for //, CHECK blocks, and assertions
-# - improved handling of foreach loops and lexicals
-# - option to use Data::Dumper for constants
-# - more bug fixes
-# - discovered lots more bugs not yet fixed
-#
-# ...
-#
-# Changes between 0.72 and 0.73
-# - support new switch constructs
-
# Todo:
# (See also BUGS section at the end of this file)
#
# 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
# name of the current package for deparsed code
#
# subs_todo:
-# array of [cop_seq, CV, is_format?] for subs and formats we still
-# want to deparse. Lexical subs have one more element, giving the pad
-# name thingy, and CV may be undef, indicating a stub declaration.
+# array of [cop_seq, CV, is_format?, name] for subs and formats we still
+# want to deparse. The fourth element is a pad name thingy for lexical
+# subs or a string for special blocks. For other subs, it is undef. For
+# lexical subs, CV may be undef, indicating a stub declaration.
#
# protos_todo:
# as above, but [name, prototype] for subs that never got a GV
# 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.
#
BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
- custom nextstate dbstate ]) {
+ kvaslice kvhslice padsv
+ nextstate dbstate rv2av rv2hv helem custom ]) {
eval "sub OP_\U$_ () { " . opnumber($_) . "}"
}}
# pessimisations end here
- if (class($op) eq 'PMOP'
- && ref($op->pmreplroot)
- && ${$op->pmreplroot}
- && $op->pmreplroot->isa( 'B::OP' ))
- {
- $self-> _pessimise_walk($op->pmreplroot);
- }
+ if (class($op) eq 'PMOP') {
+ if (ref($op->pmreplroot)
+ && ${$op->pmreplroot}
+ && $op->pmreplroot->isa( 'B::OP' ))
+ {
+ $self-> _pessimise_walk($op->pmreplroot);
+ }
+
+ # pessimise any /(?{...})/ code blocks
+ my ($re, $cv);
+ my $code_list = $op->code_list;
+ if ($$code_list) {
+ $self->_pessimise_walk($code_list);
+ }
+ elsif (${$re = $op->pmregexp} && ${$cv = $re->qr_anoncv}) {
+ $code_list = $cv->ROOT # leavesub
+ ->first # qr
+ ->code_list; # list
+ $self->_pessimise_walk($code_list);
+ }
+ }
if ($op->flags & OPf_KIDS) {
$self-> _pessimise_walk($op->first);
sub _pessimise_walk_exe {
my ($self, $startop, $visited) = @_;
+ no warnings 'recursion';
+
return unless $$startop;
return if $visited->{$$startop};
my ($op, $prevop);
sub pessimise {
my ($self, $root, $start) = @_;
+ no warnings 'recursion';
# walk tree in root-to-branch order
$self->_pessimise_walk($root);
return class($op) eq "NULL";
}
+
+# Add a CV to the list of subs that still need deparsing.
+
sub todo {
my $self = shift;
- my($cv, $is_form) = @_;
- return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
+ my($cv, $is_form, $name) = @_;
+ my $cvfile = $cv->FILE//'';
+ return unless ($cvfile eq $0 || exists $self->{files}{$cvfile});
my $seq;
if ($cv->OUTSIDE_SEQ) {
$seq = $cv->OUTSIDE_SEQ;
} else {
$seq = 0;
}
- push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
- unless ($is_form || class($cv->STASH) eq 'SPECIAL') {
- $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1;
+ my $stash = $cv->STASH;
+ if (class($stash) eq 'HV') {
+ $self->{packs}{$stash->NAME}++;
}
+ push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form, $name];
}
+
+# Pop the next sub from the todo list and deparse it
+
sub next_todo {
my $self = shift;
my $ent = shift @{$self->{'subs_todo'}};
- my $cv = $ent->[1];
- if ($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 = $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);
+
+ # XXX bit of a hack: Test::More's use_ok() method
+ # builds a fake use statement which deparses as, e.g.
+ # use Net::Ping (@{$args[0];});
+ # As well as being superfluous (the use_ok() is deparsed
+ # too) and ugly, it fails under use strict and otherwise
+ # makes use of a lexical var that's not in scope.
+ # So strip it out.
+ return $pragmata
+ if $use_dec =~
+ m/
+ \A
+ use \s \S+ \s \(\@\{
+ (
+ \s*\#line\ \d+\ \".*"\s*
+ )?
+ \$args\[0\];\}\);
+ \n
+ \Z
+ /x;
+
$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) = @_;
my $req_op = $lineseq->first->sibling;
return if $req_op->name ne "require";
+ # maybe it's C<require expr> rather than C<require 'foo'>
+ return if ($req_op->first->name ne 'const');
+
my $module;
if ($req_op->first->private & OPpCONST_BARE) {
# Actually it should always be a bareword
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";
+ if (ref $ar->[1]) {
+ # Only print a constant if it occurs in the same package as a
+ # dumped sub. This is not perfect, but a heuristic that will
+ # hopefully work most of the time. Ideally we would use
+ # CvFILE, but a constant stub has no CvFILE.
+ my $pack = ($ar->[0] =~ /(.*)::/)[0];
+ next if $pack and !$self->{packs}{$pack}
+ }
+ 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;
$self->{'ex_const'} = "'???'";
$self->{'expand'} = 0;
$self->{'files'} = {};
+ $self->{'packs'} = {};
$self->{'indent_size'} = 4;
$self->{'linenums'} = 0;
$self->{'parens'} = 0;
? $self->{'ambient_warnings'} & WARN_MASK
: undef;
$self->{'hints'} = $self->{'ambient_hints'};
- $self->{'hints'} &= 0xFF if $] < 5.009;
$self->{'hinthash'} = $self->{'ambient_hinthash'};
# also a convenient place to clear out subs_declared
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, @UNITCHECKs, @CHECKs, @INITs, @ENDs) {
- $self->todo($block, 0);
+ my @names = qw(BEGIN UNITCHECK CHECK INIT END);
+ my @blocks = \(@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs);
+ while (@names) {
+ my ($name, $blocks) = (shift @names, shift @blocks);
+ for my $block (@$blocks) {
+ $self->todo($block, 0, $name);
+ }
}
$self->stash_subs();
local($SIG{"__DIE__"}) =
local $B::overlay = {};
unless (null $root) {
$self->pad_subs($self->{'curcv'});
- $self->pessimise($root, main_start);
- print $self->indent($self->deparse_root($root)), "\n";
+ # Check for a stub-followed-by-ex-cop, resulting from a program
+ # consisting solely of sub declarations. For backward-compati-
+ # bility (and sane output) we don’t want to emit the stub.
+ # leave
+ # enter
+ # stub
+ # ex-nextstate (or ex-dbstate)
+ my $kid;
+ if ( $root->name eq 'leave'
+ and ($kid = $root->first)->name eq 'enter'
+ and !null($kid = $kid->sibling) and $kid->name eq 'stub'
+ and !null($kid = $kid->sibling) and $kid->name eq 'null'
+ and class($kid) eq 'COP' and null $kid->sibling )
+ {
+ # ignore
+ } else {
+ $self->pessimise($root, main_start);
+ print $self->indent($self->deparse_root($root)), "\n";
+ }
}
my @text;
while (scalar(@{$self->{'subs_todo'}})) {
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;
}
}
}}
sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo
}
+
+# deparse_argops(): deparse, if possible, a sequence of argcheck + argelem
+# ops into a subroutine signature. If successful, return the first op
+# following the signature ops plus the signature string; else return the
+# empty list.
+#
+# Normally a bunch of argelem ops will have been generated by the
+# signature parsing, but it's possible that ops have been added manually
+# 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.
+
+sub deparse_argops {
+ my ($self, $firstop, $cv) = @_;
+
+ my @sig;
+ my $o = $firstop;
+ return if $o->label; #first nextstate;
+
+ # OP_ARGCHECK
+
+ $o = $o->sibling;
+ 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
+
+ while (1) {
+ # OP_NEXTSTATE
+ $o = $o->sibling;
+ last unless $$o;
+ last unless $o->name =~ /^(next|db)state$/;
+ last if $o->label;
+
+ # OP_ARGELEM
+ my $o2 = $o->sibling;
+ last unless $$o2;
+
+ if ($o2->name eq 'argelem') {
+ my $ix = $o2->string($cv);
+ while (++$last_ix < $ix) {
+ push @sig, $last_ix < $mandatory ? '$' : '$=';
+ }
+ my $var = $self->padname($o2->targ);
+ if ($var =~ /^[@%]/) {
+ return if $seen_slurpy;
+ $seen_slurpy = 1;
+ return if $ix != $params or !$slurpy
+ or substr($var,0,1) ne $slurpy;
+ }
+ else {
+ return if $ix >= $params;
+ }
+ if ($o2->flags & OPf_KIDS) {
+ my $kid = $o2->first;
+ return unless $$kid and $kid->name eq 'argdefelem';
+ my $def = $self->deparse($kid->first, 7);
+ $def = "($def)" if $kid->first->flags & OPf_PARENS;
+ $var .= " = $def";
+ }
+ push @sig, $var;
+ }
+ elsif ($o2->name eq 'null'
+ and ($o2->flags & OPf_KIDS)
+ and $o2->first->name eq 'argdefelem')
+ {
+ # special case - a void context default expression: $ = expr
+
+ my $defop = $o2->first;
+ my $ix = $defop->targ;
+ while (++$last_ix < $ix) {
+ push @sig, $last_ix < $mandatory ? '$' : '$=';
+ }
+ return if $last_ix >= $params
+ or $last_ix < $mandatory;
+ my $def = $self->deparse($defop->first, 7);
+ $def = "($def)" if $defop->first->flags & OPf_PARENS;
+ push @sig, '$ = ' . $def;
+ }
+ else {
+ last;
+ }
+
+ $o = $o2;
+ }
+
+ while (++$last_ix < $params) {
+ push @sig, $last_ix < $mandatory ? '$' : '$=';
+ }
+ push @sig, $slurpy if $slurpy and !$seen_slurpy;
+
+ return ($o, join(', ', @sig));
+}
+
+# Deparse a sub. Returns everything except the 'sub foo',
+# e.g. ($$) : method { ...; }
+# or ($a, $b) : prototype($$) lvalue;
+
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, "method" if $cv->CvFLAGS & CVf_METHOD;
+ push @attrs, "const" if $cv->CvFLAGS & CVf_ANONCONST;
}
local($self->{'curcv'}) = $cv;
$self->pessimise($root, $cv->START);
my $lineseq = $root->first;
if ($lineseq->name eq "lineseq") {
- my @ops;
- for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
+ 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, $sig) = $self->deparse_argops($firstop, $cv);
+ if (defined $nexto) {
+ $firstop = $nexto;
+ $protosig = $sig;
+ }
+ }
+ }
+ }
+
+ my @ops;
+ for (my $o = $firstop; $$o; $o=$o->sibling) {
push @ops, $o;
}
$body = $self->lineseq(undef, 0, @ops).";";
+ if (!$has_sig and $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.
sub stash_variable {
my ($self, $prefix, $name, $cx) = @_;
- return "$prefix$name" if $name =~ /::/;
+ return $prefix.$self->maybe_qualify($prefix, $name) if $name =~ /::/;
unless ($prefix eq '$' || $prefix eq '@' || $prefix eq '&' || #'
$prefix eq '%' || $prefix eq '$#') {
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
}
sub maybe_qualify {
my ($self,$prefix,$name) = @_;
my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
- return $name if !$prefix || $name =~ /::/;
+ if ($prefix eq "") {
+ $name .= "::" if $name =~ /(?:\ACORE::[^:]*|::)\z/;
+ return $name;
+ }
+ return $name if $name =~ /::/;
return $self->{'curstash'}.'::'. $name
if
$name =~ /^(?!\d)\w/ # alphabetic
&& $v !~ /^\$[ab]\z/ # not $a or $b
+ && $v =~ /\A[\$\@\%\&]/ # scalar, array, hash, or sub
&& !$globalnames{$name} # not a global name
&& $self->{hints} & $strict_bits{vars} # strict vars
&& !$self->lex_in_scope($v,1) # no "our"
sub cop_subs {
my ($self, $op, $out_seq) = @_;
my $seq = $op->cop_seq;
- if ($] < 5.021006) {
- # If we have nephews, then our sequence number indicates
- # the cop_seq of the end of some sort of scope.
- if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
- and my $nseq = $self->find_scope_st($op->sibling) ) {
- $seq = $nseq;
- }
- }
$seq = $out_seq if defined($out_seq) && $out_seq < $seq;
return $self->seq_subs($seq);
}
# Skip the OUTSIDE check for lexical subs. We may be deparsing a
# cloned anon sub with lexical subs declared in it, in which case
# the OUTSIDE pointer points to the anon protosub.
- my $lexical = !!$self->{'subs_todo'}[0][3];
+ my $lexical = ref $self->{'subs_todo'}[0][3];
my $outside = !$lexical && $cv && $cv->OUTSIDE;
if (!$lexical and $cv
and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}})
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";
$self->{'warnings'} = $warning_bits;
}
- my $hints = $] < 5.008009 ? $op->private : $op->hints;
+ my $hints = $op->hints;
my $old_hints = $self->{'hints'};
if ($self->{'hints'} != $hints) {
push @text, $self->declare_hints($self->{'hints'}, $hints);
}
my $newhh;
- if ($] > 5.009) {
- $newhh = $op->hints_hash->HASH;
- }
+ $newhh = $op->hints_hash->HASH;
- if ($] >= 5.015006) {
+ {
# feature bundle hints
my $from = $old_hints & $feature::hint_mask;
my $to = $ hints & $feature::hint_mask;
$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";
}
}
}
- if ($] > 5.009) {
+ {
push @text, $self->declare_hinthash(
$self->{'hinthash'}, $newhh,
$self->{indent_size}, $self->{hints},
$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 {
my @unfeatures; # bugs?
for my $key (sort keys %$to) {
next if $ignored_hints{$key};
- my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6;
+ my $is_feature = $key =~ /^feature_/;
next if $is_feature and not $doing_features;
if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) {
push(@features, $key), next if $is_feature;
}
for my $key (sort keys %$from) {
next if $ignored_hints{$key};
- my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6;
+ my $is_feature = $key =~ /^feature_/;
next if $is_feature and not $doing_features;
if (!exists $to->{$key}) {
push(@unfeatures, $key), next if $is_feature;
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;
}
if ($nollafr) {
- ($kid = $self->deparse($kid, 16)) =~ s/^\cS//;
+ if (($kid = $self->deparse($kid, 16)) !~ s/^\cS//) {
+ # require foo() is a syntax error.
+ $kid =~ /^(?!\d)\w/ and $kid = "($kid)";
+ }
return $self->maybe_parens(
$self->keyword($name) . " $kid", $cx, 16
);
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") }
sub pp_entereval {
unop(
@_,
- $_[1]->private & OPpEVAL_BYTES ? $_[0]->keyword('evalbytes') : "eval"
+ $_[1]->private & OPpEVAL_BYTES ? 'evalbytes' : "eval"
)
}
my($op, $cx) = @_;
my $arg;
my $name = $self->keyword("delete");
- if ($op->private & OPpSLICE) {
+ if ($op->private & (OPpSLICE|OPpKVSLICE)) {
if ($op->flags & OPf_SPECIAL) {
# Deleting from an array, not a hash
return $self->maybe_parens_func($name,
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");
}
# no-op
} elsif (class($op) eq "UNOP") {
(my $kid = $self->deparse($op->first, 7)) =~ s/^\cS//;
+ # last foo() is a syntax error.
+ $kid =~ /^(?!\d)\w/ and $kid = "($kid)";
$name .= " $kid";
}
return $self->maybe_parens($name, $cx, 7);
'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) }
sub pp_smartmatch {
my ($self, $op, $cx) = @_;
- if ($op->flags & OPf_SPECIAL) {
+ if (($op->flags & OPf_SPECIAL) && $self->{expand} < 2) {
return $self->deparse($op->last, $cx);
}
else {
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) . ")";
}
maybe_local(@_, listop(@_, "substr"))
}
+
+sub pp_index {
+ # Also handles pp_rindex.
+ #
+ # The body of this function includes an unrolled maybe_targmy(),
+ # since the two parts of that sub's actions need to have have the
+ # '== -1' bit in between
+
+ my($self, $op, $cx) = @_;
+
+ my $lex = ($op->private & OPpTARGET_MY);
+ my $bool = ($op->private & OPpTRUEBOOL);
+
+ my $val = $self->listop($op, ($bool ? 14 : $lex ? 7 : $cx), $op->name);
+
+ # (index() == -1) has op_eq and op_const optimised away
+ if ($bool) {
+ $val .= ($op->private & OPpINDEX_BOOLNEG) ? " == -1" : " != -1";
+ $val = "($val)" if ($op->flags & OPf_PARENS);
+ }
+ if ($lex) {
+ my $var = $self->padname($op->targ);
+ $val = $self->maybe_parens("$var = $val", $cx, 7);
+ }
+ $val;
+}
+
+sub pp_rindex { pp_index(@_); }
sub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) }
-sub pp_index { maybe_targmy(@_, \&listop, "index") }
-sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
sub pp_formline { listop(@_, "formline") } # see also deparse_format
sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
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);
}
}
hslice delete padsv padav padhv enteriter entersub padrange
pushmark cond_expr refassign list)
} = ();
- delete @uses_intro{qw( lvref lvrefslice lvavref )};
+ delete @uses_intro{qw( lvref lvrefslice lvavref entersub )};
+}
+
+
+# Look for a my attribute declaration in a list or ex-list. Returns undef
+# if not found, 'my($x, @a) :Foo(bar)' etc otherwise.
+#
+# There are three basic tree structs that are expected:
+#
+# my $x :foo;
+# <1> ex-list vK/LVINTRO ->c
+# <0> ex-pushmark v ->3
+# <1> entersub[t2] vKRS*/TARG ->b
+# ....
+# <0> padsv[$x:64,65] vM/LVINTRO ->c
+#
+# my @a :foo;
+# my %h :foo;
+#
+# <1> ex-list vK ->c
+# <0> ex-pushmark v ->3
+# <0> padav[@a:64,65] vM/LVINTRO ->4
+# <1> entersub[t2] vKRS*/TARG ->c
+# ....
+#
+# my ($x,@a,%h) :foo;
+#
+# <;> nextstate(main 64 -e:1) v:{ ->3
+# <@> list vKP ->w
+# <0> pushmark vM/LVINTRO ->4
+# <0> padsv[$x:64,65] vM/LVINTRO ->5
+# <0> padav[@a:64,65] vM/LVINTRO ->6
+# <0> padhv[%h:64,65] vM/LVINTRO ->7
+# <1> entersub[t4] vKRS*/TARG ->f
+# ....
+# <1> entersub[t5] vKRS*/TARG ->n
+# ....
+# <1> entersub[t6] vKRS*/TARG ->v
+# ....
+# where the entersub in all cases looks like
+# <1> entersub[t2] vKRS*/TARG ->c
+# <0> pushmark s ->5
+# <$> const[PV "attributes"] sM ->6
+# <$> const[PV "main"] sM ->7
+# <1> srefgen sKM/1 ->9
+# <1> ex-list lKRM ->8
+# <0> padsv[@a:64,65] sRM ->8
+# <$> const[PV "foo"] sM ->a
+# <.> method_named[PV "import"] ->b
+
+sub maybe_my_attr {
+ my ($self, $op, $cx) = @_;
+
+ my $kid = $op->first->sibling; # skip pushmark
+ return if class($kid) eq 'NULL';
+
+ my $lop;
+ my $type;
+
+ # Extract out all the pad ops and entersub ops into
+ # @padops and @entersubops. Return if anything else seen.
+ # Also determine what class (if any) all the pad vars belong to
+ my $class;
+ my (@padops, @entersubops);
+ for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
+ my $lopname = $lop->name;
+ my $loppriv = $lop->private;
+ if ($lopname =~ /^pad[sah]v$/) {
+ return unless $loppriv & OPpLVAL_INTRO;
+ return if $loppriv & OPpPAD_STATE;
+
+ my $padname = $self->padname_sv($lop->targ);
+ my $thisclass = ($padname->FLAGS & SVpad_TYPED)
+ ? $padname->SvSTASH->NAME : 'main';
+
+ # all pad vars must be in the same class
+ $class //= $thisclass;
+ return unless $thisclass eq $class;
+
+ push @padops, $lop;
+ }
+ elsif ($lopname eq 'entersub') {
+ push @entersubops, $lop;
+ }
+ else {
+ return;
+ }
+ }
+
+ return unless @padops && @padops == @entersubops;
+
+ # there should be a balance: each padop has a corresponding
+ # 'attributes'->import() method call, in the same order.
+
+ my @varnames;
+ my $attr_text;
+
+ for my $i (0..$#padops) {
+ my $padop = $padops[$i];
+ my $esop = $entersubops[$i];
+
+ push @varnames, $self->padname($padop->targ);
+
+ return unless ($esop->flags & OPf_KIDS);
+
+ my $kid = $esop->first;
+ return unless $kid->type == OP_PUSHMARK;
+
+ $kid = $kid->sibling;
+ return unless $$kid && $kid->type == OP_CONST;
+ return unless $self->const_sv($kid)->PV eq 'attributes';
+
+ $kid = $kid->sibling;
+ return unless $$kid && $kid->type == OP_CONST; # __PACKAGE__
+
+ $kid = $kid->sibling;
+ return unless $$kid
+ && $kid->name eq "srefgen"
+ && ($kid->flags & OPf_KIDS)
+ && ($kid->first->flags & OPf_KIDS)
+ && $kid->first->first->name =~ /^pad[sah]v$/
+ && $kid->first->first->targ == $padop->targ;
+
+ $kid = $kid->sibling;
+ my @attr;
+ while ($$kid) {
+ last if ($kid->type != OP_CONST);
+ push @attr, $self->const_sv($kid)->PV;
+ $kid = $kid->sibling;
+ }
+ return unless @attr;
+ my $thisattr = ":" . join(' ', @attr);
+ $attr_text //= $thisattr;
+ # all import calls must have the same list of attributes
+ return unless $attr_text eq $thisattr;
+
+ return unless $kid->name eq 'method_named';
+ return unless $self->meth_sv($kid)->PV eq 'import';
+
+ $kid = $kid->sibling;
+ return if $$kid;
+ }
+
+ my $res = 'my';
+ $res .= " $class " if $class ne 'main';
+ $res .=
+ (@varnames > 1)
+ ? "(" . join(', ', @varnames) . ')'
+ : " $varnames[0]";
+
+ return "$res $attr_text";
}
+
sub pp_list {
my $self = shift;
my($op, $cx) = @_;
+
+ {
+ # might be my ($s,@a,%h) :Foo(bar);
+ my $my_attr = maybe_my_attr($self, $op, $cx);
+ return $my_attr if defined $my_attr;
+ }
+
my($expr, @exprs);
my $kid = $op->first->sibling; # skip pushmark
return '' if class($kid) eq 'NULL';
}
} elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/
&& $loppriv & OPpOUR_INTRO
- or $lopname eq "null" && $lop->first->name eq "gvsv"
+ or $lopname eq "null" && class($lop) eq 'UNOP'
+ && $lop->first->name eq "gvsv"
&& $lop->first->private & OPpOUR_INTRO) { # our()
my $newlocal = "local " x !!($loppriv & OPpLVAL_INTRO) . "our";
($local = "", last)
sub pp_null {
my($self, $op, $cx) = @_;
+
+ # might be 'my $s :Foo(bar);'
+ if ($op->targ == OP_LIST) {
+ my $my_attr = maybe_my_attr($self, $op, $cx);
+ return $my_attr if defined $my_attr;
+ }
+
if (class($op) eq "OP") {
# old value is lost
return $self->{'ex_const'} if $op->targ == OP_CONST;
}
sub pp_padav { pp_padsv(@_) }
-sub pp_padhv { pp_padsv(@_) }
+
+# prepend 'keys' where its been optimised away, with suitable handling
+# of CORE:: and parens
+
+sub add_keys_keyword {
+ my ($self, $str, $cx) = @_;
+ $str = $self->maybe_parens($str, $cx, 16);
+ # 'keys %h' versus 'keys(%h)'
+ $str = " $str" unless $str =~ /^\(/;
+ return $self->keyword("keys") . $str;
+}
+
+sub pp_padhv {
+ my ($self, $op, $cx) = @_;
+ my $str = pp_padsv(@_);
+ # with OPpPADHV_ISKEYS the keys op is optimised away, except
+ # in scalar context the old op is kept (but not executed) so its targ
+ # can be used.
+ if ( ($op->private & OPpPADHV_ISKEYS)
+ && !(($op->flags & OPf_WANT) == OPf_WANT_SCALAR))
+ {
+ $str = $self->add_keys_keyword($str, $cx);
+ }
+ $str;
+}
sub gv_or_padgv {
my $self = shift;
my $self = shift;
my($op, $cx) = @_;
my $gv = $self->gv_or_padgv($op);
- return $self->gv_name($gv);
+ return $self->maybe_qualify("", $self->gv_name($gv));
}
sub pp_aelemfast_lex {
}
my $kid = $op->first;
if ($kid->name eq "gv") {
- return $self->stash_variable($type, $self->deparse($kid, 0), $cx);
+ return $self->stash_variable($type,
+ $self->gv_name($self->gv_or_padgv($kid)), $cx);
} elsif (is_scalar $kid) {
my $str = $self->deparse($kid, 0);
if ($str =~ /^\$([^\w\d])\z/) {
}
sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
-sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
+sub pp_rv2hv {
+ my ($self, $op, $cx) = @_;
+ my $str = rv2x(@_, "%");
+ if ($op->private & OPpRV2HV_ISKEYS) {
+ $str = $self->add_keys_keyword($str, $cx);
+ }
+ return maybe_local(@_, $str);
+}
+
# skip rv2av
sub pp_av2arylen {
my $self = shift;
sub is_subscriptable {
my $op = shift;
- if ($op->name =~ /^[ahg]elem/) {
+ if ($op->name =~ /^([ahg]elem|multideref$)/) {
return 1;
} elsif ($op->name eq "entersub") {
my $kid = $op->first;
}
+# a simplified version of elem_or_slice_array_name()
+# for the use of pp_multideref
+
+sub multideref_var_name {
+ my $self = shift;
+ my ($gv, $is_hash) = @_;
+
+ my ($name, $quoted) =
+ $self->stash_variable_name( $is_hash ? '%' : '@', $gv);
+ return $quoted ? "$name->"
+ : $name eq '#'
+ ? '${#}' # avoid ${#}[1] => $#[1]
+ : '$' . $name;
+}
+
+
+# deparse an OP_MULTICONCAT. If $in_dq is 1, we're within
+# a double-quoted string, so for example.
+# "abc\Qdef$x\Ebar"
+# might get compiled as
+# multiconcat("abc", metaquote(multiconcat("def", $x)), "bar")
+# and the inner multiconcat should be deparsed as C<def$x> rather than
+# the normal C<def . $x>
+# Ditto if $in_dq is 2, handle qr/...\Qdef$x\E.../.
+
+sub do_multiconcat {
+ my $self = shift;
+ my($op, $cx, $in_dq) = @_;
+
+ my $kid;
+ my @kids;
+ my $assign;
+ my $append;
+ my $lhs = "";
+
+ for ($kid = $op->first; !null $kid; $kid = $kid->sibling) {
+ # skip the consts and/or padsv we've optimised away
+ push @kids, $kid
+ unless $kid->type == OP_NULL
+ && ( $kid->targ == OP_PADSV
+ || $kid->targ == OP_CONST
+ || $kid->targ == OP_PUSHMARK);
+ }
+
+ $append = ($op->private & OPpMULTICONCAT_APPEND);
+
+ if ($op->private & OPpTARGET_MY) {
+ # '$lex = ...' or '$lex .= ....' or 'my $lex = '
+ $lhs = $self->padname($op->targ);
+ $lhs = "my $lhs" if ($op->private & OPpLVAL_INTRO);
+ $assign = 1;
+ }
+ elsif ($op->flags & OPf_STACKED) {
+ # 'expr = ...' or 'expr .= ....'
+ my $expr = $append ? shift(@kids) : pop(@kids);
+ $lhs = $self->deparse($expr, 7);
+ $assign = 1;
+ }
+
+ if ($assign) {
+ $lhs .= $append ? ' .= ' : ' = ';
+ }
+
+ my ($nargs, $const_str, @const_lens) = $op->aux_list($self->{curcv});
+
+ my @consts;
+ my $i = 0;
+ for (@const_lens) {
+ if ($_ == -1) {
+ push @consts, undef;
+ }
+ else {
+ push @consts, substr($const_str, $i, $_);
+ my @args;
+ $i += $_;
+ }
+ }
+
+ my $rhs = "";
+
+ if ( $in_dq
+ || (($op->private & OPpMULTICONCAT_STRINGIFY) && !$self->{'unquote'}))
+ {
+ # "foo=$foo bar=$bar "
+ my $not_first;
+ while (@consts) {
+ $rhs = dq_disambiguate($rhs, $self->dq(shift(@kids), 18))
+ if $not_first;
+ $not_first = 1;
+ my $c = shift @consts;
+ if (defined $c) {
+ if ($in_dq == 2) {
+ # in pattern: don't convert newline to '\n' etc etc
+ my $s = re_uninterp(escape_re(re_unback($c)));
+ $rhs = re_dq_disambiguate($rhs, $s)
+ }
+ else {
+ my $s = uninterp(escape_str(unback($c)));
+ $rhs = dq_disambiguate($rhs, $s)
+ }
+ }
+ }
+ return $rhs if $in_dq;
+ $rhs = single_delim("qq", '"', $rhs, $self);
+ }
+ elsif ($op->private & OPpMULTICONCAT_FAKE) {
+ # sprintf("foo=%s bar=%s ", $foo, $bar)
+
+ my @all;
+ @consts = map { $_ //= ''; s/%/%%/g; $_ } @consts;
+ my $fmt = join '%s', @consts;
+ push @all, $self->quoted_const_str($fmt);
+
+ # the following is a stripped down copy of sub listop {}
+ my $parens = $assign || ($cx >= 5) || $self->{'parens'};
+ my $fullname = $self->keyword('sprintf');
+ push @all, map $self->deparse($_, 6), @kids;
+
+ $rhs = $parens
+ ? "$fullname(" . join(", ", @all) . ")"
+ : "$fullname " . join(", ", @all);
+ }
+ else {
+ # "foo=" . $foo . " bar=" . $bar
+ my @all;
+ my $not_first;
+ while (@consts) {
+ push @all, $self->deparse(shift(@kids), 18) if $not_first;
+ $not_first = 1;
+ my $c = shift @consts;
+ if (defined $c) {
+ push @all, $self->quoted_const_str($c);
+ }
+ }
+ $rhs .= join ' . ', @all;
+ }
+
+ my $text = $lhs . $rhs;
+
+ $text = "($text)" if ($cx >= (($assign) ? 7 : 18+1))
+ || $self->{'parens'};
+
+ return $text;
+}
+
+
+sub pp_multiconcat {
+ my $self = shift;
+ $self->do_multiconcat(@_, 0);
+}
+
+
+sub pp_multideref {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $text = "";
+
+ if ($op->private & OPpMULTIDEREF_EXISTS) {
+ $text = $self->keyword("exists"). " ";
+ }
+ elsif ($op->private & OPpMULTIDEREF_DELETE) {
+ $text = $self->keyword("delete"). " ";
+ }
+ elsif ($op->private & OPpLVAL_INTRO) {
+ $text = $self->keyword("local"). " ";
+ }
+
+ if ($op->first && ($op->first->flags & OPf_KIDS)) {
+ # arbitrary initial expression, e.g. f(1,2,3)->[...]
+ 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});
+ my $actions = shift @items;
+
+ my $is_hash;
+ my $derefs = 0;
+
+ while (1) {
+ if (($actions & MDEREF_ACTION_MASK) == MDEREF_reload) {
+ $actions = shift @items;
+ next;
+ }
+
+ $is_hash = (
+ ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_pop_rv2hv_helem
+ || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvsv_vivify_rv2hv_helem
+ || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padsv_vivify_rv2hv_helem
+ || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_vivify_rv2hv_helem
+ || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem
+ || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem
+ );
+
+ if ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_padav_aelem
+ || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem)
+ {
+ $derefs = 1;
+ $text .= '$' . substr($self->padname(shift @items), 1);
+ }
+ elsif ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_gvav_aelem
+ || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem)
+ {
+ $derefs = 1;
+ $text .= $self->multideref_var_name(shift @items, $is_hash);
+ }
+ else {
+ if ( ($actions & MDEREF_ACTION_MASK) ==
+ MDEREF_AV_padsv_vivify_rv2av_aelem
+ || ($actions & MDEREF_ACTION_MASK) ==
+ MDEREF_HV_padsv_vivify_rv2hv_helem)
+ {
+ $text .= $self->padname(shift @items);
+ }
+ elsif ( ($actions & MDEREF_ACTION_MASK) ==
+ MDEREF_AV_gvsv_vivify_rv2av_aelem
+ || ($actions & MDEREF_ACTION_MASK) ==
+ MDEREF_HV_gvsv_vivify_rv2hv_helem)
+ {
+ $text .= $self->multideref_var_name(shift @items, $is_hash);
+ }
+ elsif ( ($actions & MDEREF_ACTION_MASK) ==
+ MDEREF_AV_pop_rv2av_aelem
+ || ($actions & MDEREF_ACTION_MASK) ==
+ MDEREF_HV_pop_rv2hv_helem)
+ {
+ if ( ($op->flags & OPf_KIDS)
+ && ( _op_is_or_was($op->first, OP_RV2AV)
+ || _op_is_or_was($op->first, OP_RV2HV))
+ && ($op->first->flags & OPf_KIDS)
+ && ( _op_is_or_was($op->first->first, OP_AELEM)
+ || _op_is_or_was($op->first->first, OP_HELEM))
+ )
+ {
+ $derefs++;
+ }
+ }
+
+ $text .= '->' if !$derefs++;
+ }
+
+
+ if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_none) {
+ last;
+ }
+
+ $text .= $is_hash ? '{' : '[';
+
+ if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_const) {
+ my $key = shift @items;
+ if ($is_hash) {
+ $text .= $self->const($key, $cx);
+ }
+ else {
+ $text .= $key;
+ }
+ }
+ elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_padsv) {
+ $text .= $self->padname(shift @items);
+ }
+ elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_gvsv) {
+ $text .= '$' . ($self->stash_variable_name('$', shift @items))[0];
+ }
+
+ $text .= $is_hash ? '}' : ']';
+
+ if ($actions & MDEREF_FLAG_last) {
+ last;
+ }
+ $actions >>= MDEREF_SHIFT;
+ }
+
+ return $text;
+}
+
+
sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
my $scope = is_scope($glob);
$glob = $self->deparse($glob, 0);
$part = $self->deparse($part, 1);
+ $glob =~ s/::\z// unless $scope;
return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
}
} else {
$list = $self->elem_or_slice_single_index($kid);
}
- my $lead = '@';
- $lead = '%' if $op->name =~ /^kv/i;
+ my $lead = ( _op_is_or_was($op, OP_KVHSLICE)
+ || _op_is_or_was($op, OP_KVASLICE))
+ ? '%' : '@';
return $lead . $array . $left . $list . $right;
}
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;
return ("", join ", ", @reals);
}
+sub retscalar {
+ my $name = $_[0]->name;
+ # XXX There has to be a better way of doing this scalar-op check.
+ # Currently PL_opargs is not exposed.
+ if ($name eq 'null') {
+ $name = substr B::ppname($_[0]->targ), 3
+ }
+ $name =~ /^(?:scalar|pushmark|wantarray|const|gvsv|gv|padsv|rv2gv
+ |rv2sv|av2arylen|anoncode|prototype|srefgen|ref|bless
+ |regcmaybe|regcreset|regcomp|qr|subst|substcont|trans
+ |transr|sassign|chop|schop|chomp|schomp|defined|undef
+ |study|pos|preinc|i_preinc|predec|i_predec|postinc
+ |i_postinc|postdec|i_postdec|pow|multiply|i_multiply
+ |divide|i_divide|modulo|i_modulo|add|i_add|subtract
+ |i_subtract|concat|multiconcat|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|[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
+ |pack|join|anonlist|anonhash|push|pop|shift|unshift|xor
+ |andassign|orassign|dorassign|warn|die|reset|nextstate
+ |dbstate|unstack|last|next|redo|dump|goto|exit|open|close
+ |pipe_op|fileno|umask|binmode|tie|untie|tied|dbmopen
+ |dbmclose|select|getc|read|enterwrite|prtf|print|say
+ |sysopen|sysseek|sysread|syswrite|eof|tell|seek|truncate
+ |fcntl|ioctl|flock|send|recv|socket|sockpair|bind|connect
+ |listen|accept|shutdown|gsockopt|ssockopt|getsockname
+ |getpeername|ftrread|ftrwrite|ftrexec|fteread|ftewrite
+ |fteexec|ftis|ftsize|ftmtime|ftatime|ftctime|ftrowned
+ |fteowned|ftzero|ftsock|ftchr|ftblk|ftfile|ftdir|ftpipe
+ |ftsuid|ftsgid|ftsvtx|ftlink|fttty|fttext|ftbinary|chdir
+ |chown|chroot|unlink|chmod|utime|rename|link|symlink
+ |readlink|mkdir|rmdir|open_dir|telldir|seekdir|rewinddir
+ |closedir|fork|wait|waitpid|system|exec|kill|getppid
+ |getpgrp|setpgrp|getpriority|setpriority|time|alarm|sleep
+ |shmget|shmctl|shmread|shmwrite|msgget|msgctl|msgsnd
+ |msgrcv|semop|semget|semctl|hintseval|shostent|snetent
+ |sprotoent|sservent|ehostent|enetent|eprotoent|eservent
+ |spwent|epwent|sgrent|egrent|getlogin|syscall|lock|runcv
+ |fc)\z/x
+}
+
sub pp_entersub {
my $self = shift;
my($op, $cx) = @_;
}
my $simple = 0;
my $proto = undef;
+ my $lexical;
if (is_scope($kid)) {
$amper = "&";
$kid = "{" . $self->deparse($kid, 0) . "}";
$proto = $cv->PV if $cv->FLAGS & SVf_POK;
}
$simple = 1; # only calls of named functions can be prototyped
- $kid = $self->deparse($kid, 24);
+ $kid = $self->maybe_qualify("!", $self->gv_name($gv));
my $fq;
# Fully qualify any sub name that conflicts with a lexical.
if ($self->lex_in_scope("&$kid")
$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;
+ my $listargs = 1;
if ($declared and defined $proto and not $amper) {
($amper, $args) = $self->check_proto($proto, @exprs);
- if ($amper eq "&") {
- $args = join(", ", map($self->deparse($_, 6), @exprs));
- }
- } else {
- $args = join(", ", map($self->deparse($_, 6), @exprs));
+ $listargs = $amper;
+ }
+ if ($listargs) {
+ $args = join(", ", map(
+ ($_->flags & OPf_WANT) == OPf_WANT_SCALAR
+ && !retscalar($_)
+ ? $self->maybe_parens_unop('scalar', $_, 6)
+ : $self->deparse($_, 6),
+ @exprs
+ ));
}
if ($prefix or $amper) {
if ($kid eq '&') { $kid = "{$kid}" } # &{&} cannot be written as &&
$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 . ")";
}
# the same, but treat $|, $), $( and $ at the end of the string differently
+# and leave comments unmangled for the sake of /x and (?x).
sub re_uninterp {
my($str) = @_;
)
( # $3
- (\(\?\??\{$bal\}\)) # $4
- | [\$\@]
- (?!\||\)|\(|$)
- | \\[uUlLQE]
- )
-
- /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
-
- return $str;
-}
-
-# This is for regular expressions with the /x modifier
-# We have to leave comments unmangled.
-sub re_uninterp_extended {
- my($str) = @_;
-
- $str =~ s/
- ( ^|\G # $1
- | [^\\]
- )
-
- ( # $2
- (?:\\\\)*
- )
-
- ( # $3
( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
| \#[^\n]* # (skip over comments)
)
}
}
-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;
}
-# For regexes with the /x modifier.
-# Leave whitespace unmangled.
-sub escape_extended_re {
+# For regexes. Leave whitespace unmangled in case of /x or (?x).
+sub escape_re {
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;
}
# Remove backslashes which precede literal control characters,
# to avoid creating ambiguity when we escape the latter.
+#
+# Don't remove a backslash from escaped whitespace: where the T represents
+# a literal tab character, /T/x is not equivalent to /\T/x
+
sub re_unback {
my($str) = @_;
# the insane complexity here is due to the behaviour of "\c\"
- $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
+ $str =~ s/
+ # these two lines ensure that the backslash we're about to
+ # remove isn't preceeded by something which makes it part
+ # of a \c
+
+ (^ | [^\\] | \\c\\) # $1
+ (?<!\\c)
+
+ # the backslash to remove
+ \\
+
+ # keep pairs of backslashes
+ (\\\\)* # $2
+
+ # only remove if the thing following is a control char
+ (?=[[:^print:]])
+ # and not whitespace
+ (?=\S)
+ /$1$2/xg;
return $str;
}
return ($mantissa, $exponent);
}
+
+# suitably single- or double-quote a literal constant string
+
+sub quoted_const_str {
+ my ($self, $str) =@_;
+ if ($str =~ /[[:^print:]]/a) {
+ return single_delim("qq", '"',
+ uninterp(escape_str unback $str), $self);
+ } else {
+ return single_delim("q", "'", unback($str), $self);
+ }
+}
+
+
sub const {
my $self = shift;
my($sv, $cx) = @_;
}
if (class($sv) eq "SPECIAL") {
# sv_undef, sv_yes, sv_no
- return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1];
+ return $$sv == 3 ? $self->maybe_parens("!1", $cx, 21)
+ : ('undef', '1')[$$sv-1];
}
if (class($sv) eq "NULL") {
return 'undef';
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") {
- BEGIN {
- if ($] > 5.0150051) {
- require overloading;
- unimport overloading;
- }
- }
- if ($] > 5.0150051 && $self->{curcv} &&
+ } elsif ($class eq "CV") {
+ no overloading;
+ if ($self->{curcv} &&
$self->{curcv}->object_2svref == $ref->object_2svref) {
return $self->keyword("__SUB__");
}
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_str(re_unback($mg->precomp)));
+ my $re = re_uninterp(escape_re(re_unback($mg->precomp)));
return single_delim("qr", "", $re, $self);
}
}
return $self->maybe_parens("\\$const", $cx, 20);
} elsif ($sv->FLAGS & SVf_POK) {
my $str = $sv->PV;
- if ($str =~ /[[:^print:]]/) {
- return single_delim("qq", '"',
- uninterp(escape_str unback $str), $self);
- } else {
- return single_delim("q", "'", unback($str), $self);
- }
+ return $self->quoted_const_str($str);
} else {
return "undef";
}
return $self->const($sv, $cx);
}
+
+# Join two components of a double-quoted string, disambiguating
+# "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
+
+sub dq_disambiguate {
+ my ($first, $last) = @_;
+ ($last =~ /^[A-Z\\\^\[\]_?]/ &&
+ $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
+ || ($last =~ /^[:'{\[\w_]/ && #'
+ $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
+ return $first . $last;
+}
+
+
+# Deparse a double-quoted optree. For example, "$a[0]\Q$b\Efo\"o" gets
+# compiled to concat(concat($[0],quotemeta($b)),const("fo\"o")), and this
+# sub deparses it back to $a[0]\Q$b\Efo"o
+# (It does not add delimiters)
+
sub dq {
my $self = shift;
my $op = shift;
return '$[' if $op->private & OPpCONST_ARYBASE;
return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
} elsif ($type eq "concat") {
- my $first = $self->dq($op->first);
- my $last = $self->dq($op->last);
-
- # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
- ($last =~ /^[A-Z\\\^\[\]_?]/ &&
- $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
- || ($last =~ /^[:'{\[\w_]/ && #'
- $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
-
- return $first . $last;
+ return dq_disambiguate($self->dq($op->first), $self->dq($op->last));
+ } elsif ($type eq "multiconcat") {
+ return $self->do_multiconcat($op, 26, 1);
} elsif ($type eq "uc") {
return '\U' . $self->dq($op->first->sibling) . '\E';
} elsif ($type eq "lc") {
while ($kid->name eq 'null' && !null($kid->first)) {
$kid = $kid->first;
}
- if ($kid->name =~ /^(?:const|padsv|rv2sv|av2arylen|gvsv
+ if ($kid->name =~ /^(?:const|padsv|rv2sv|av2arylen|gvsv|multideref
|aelemfast(?:_lex)?|[ah]elem|join|concat)\z/x) {
maybe_targmy(@_, \&dquote);
}
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);
sub pp_transr { push @_, 'r'; goto &pp_trans }
+# Join two components of a double-quoted re, disambiguating
+# "${foo}bar", "${foo}{bar}", "${foo}[1]".
+
sub re_dq_disambiguate {
my ($first, $last) = @_;
- # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
($last =~ /^[A-Z\\\^\[\]_?]/ &&
$first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
|| ($last =~ /^[{\[\w_]/ &&
# Like dq(), but different
sub re_dq {
my $self = shift;
- my ($op, $extended) = @_;
+ my ($op) = @_;
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_extended(escape_extended_re($unbacked))
- if $extended;
- return re_uninterp(escape_str($unbacked));
+ return re_uninterp(escape_re($unbacked));
} elsif ($type eq "concat") {
- my $first = $self->re_dq($op->first, $extended);
- my $last = $self->re_dq($op->last, $extended);
+ my $first = $self->re_dq($op->first);
+ my $last = $self->re_dq($op->last);
return re_dq_disambiguate($first, $last);
+ } elsif ($type eq "multiconcat") {
+ return $self->do_multiconcat($op, 26, 2);
} elsif ($type eq "uc") {
- return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
+ return '\U' . $self->re_dq($op->first->sibling) . '\E';
} elsif ($type eq "lc") {
- return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
+ return '\L' . $self->re_dq($op->first->sibling) . '\E';
} elsif ($type eq "ucfirst") {
- return '\u' . $self->re_dq($op->first->sibling, $extended);
+ return '\u' . $self->re_dq($op->first->sibling);
} elsif ($type eq "lcfirst") {
- return '\l' . $self->re_dq($op->first->sibling, $extended);
+ return '\l' . $self->re_dq($op->first->sibling);
} elsif ($type eq "quotemeta") {
- return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
+ return '\Q' . $self->re_dq($op->first->sibling) . '\E';
} elsif ($type eq "fc") {
- return '\F' . $self->re_dq($op->first->sibling, $extended) . '\E';
+ return '\F' . $self->re_dq($op->first->sibling) . '\E';
} elsif ($type eq "join") {
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;
}
}
return $self->pure_string($op->first)
&& $self->pure_string($op->last);
}
- elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
- return 1;
+ elsif ($type eq 'multiconcat') {
+ my ($kid, @kids);
+ for ($kid = $op->first; !null $kid; $kid = $kid->sibling) {
+ # skip the consts and/or padsv we've optimised away
+ push @kids, $kid
+ unless $kid->type == OP_NULL
+ && ( $kid->targ == OP_PADSV
+ || $kid->targ == OP_CONST
+ || $kid->targ == OP_PUSHMARK);
+ }
+
+ if ($op->flags & OPf_STACKED) {
+ # remove expr from @kids where 'expr = ...' or 'expr .= ....'
+ if ($op->private & OPpMULTICONCAT_APPEND) {
+ shift(@kids);
+ }
+ else {
+ pop(@kids);
+ }
+ }
+ for (@kids) {
+ return 0 unless $self->pure_string($_);
+ }
+ return 1;
}
- elsif ($type eq "null" and $op->can('first') and not null $op->first and
- ($op->first->name eq "null" and $op->first->can('first')
- and not null $op->first->first and
- $op->first->first->name eq "aelemfast"
- or
- $op->first->name =~ /^aelemfast(?:_lex)?\z/
- )) {
+ elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
return 1;
}
- else {
- return 0;
+ elsif ($type eq "null" and $op->can('first') and not null $op->first) {
+ my $first = $op->first;
+
+ return 1 if $first->name eq "multideref";
+ return 1 if $first->name eq "aelemfast_lex";
+
+ if ( $first->name eq "null"
+ and $first->can('first')
+ and not null $first->first
+ and $first->first->name eq "aelemfast"
+ )
+ {
+ return 1;
+ }
}
- return 1;
+ return 0;
}
sub code_list {
- my ($self,$op,$extended,$cv) = @_;
+ my ($self,$op,$cv) = @_;
# localise stuff relating to the current sub
$cv and
$re .= $block;
$re .= $multiline ? "\n\b})" : " })";
} else {
- $re = re_dq_disambiguate($re, $self->re_dq($op, $extended));
+ $re = re_dq_disambiguate($re, $self->re_dq($op));
}
}
$re;
sub regcomp {
my $self = shift;
- my($op, $cx, $extended) = @_;
+ my($op, $cx) = @_;
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 = '';
$kid = $kid->first->sibling;
while (!null($kid)) {
my $first = $str;
- my $last = $self->re_dq($kid, $extended);
+ my $last = $self->re_dq($kid);
$str = re_dq_disambiguate($first, $last);
$kid = $kid->sibling;
}
return $str, 1;
}
- return ($self->re_dq($kid, $extended), 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.
my($op, $cx, $name, $delim) = @_;
my $kid = $op->first;
my ($binop, $var, $re) = ("", "", "");
- if ($op->flags & OPf_STACKED) {
+ if ($op->name ne 'split' && $op->flags & OPf_STACKED) {
$binop = 1;
$var = $self->deparse($kid, 20);
$kid = $kid->sibling;
}
my $quote = 1;
my $pmflags = $op->pmflags;
- my $extended = ($pmflags & PMf_EXTENDED);
my $rhs_bound_to_defsv;
my ($cv, $bregexp);
my $have_kid = !null $kid;
# Check for code blocks first
if (not null my $code_list = $op->code_list) {
- $re = $self->code_list($code_list, $extended,
+ $re = $self->code_list($code_list,
$op->name eq 'qr'
? $self->padval(
$kid->first # ex-list
my $patop = $cv->ROOT # leavesub
->first # qr
->code_list;# list
- $re = $self->code_list($patop, $extended, $cv);
+ $re = $self->code_list($patop, $cv);
} elsif (!$have_kid) {
- my $unbacked = re_unback($op->precomp);
- if ($extended) {
- $re = re_uninterp_extended(escape_extended_re($unbacked));
- } else {
- $re = re_uninterp(escape_str($unbacked));
- }
+ $re = re_uninterp(escape_re(re_unback($op->precomp)));
} elsif ($kid->name ne 'regcomp') {
- carp("found ".$kid->name." where regcomp expected");
+ if ($op->name eq 'split') {
+ # split has other kids, not just regcomp
+ $re = re_uninterp(escape_re(re_unback($op->precomp)));
+ }
+ else {
+ carp("found ".$kid->name." where regcomp expected");
+ }
} else {
- ($re, $quote) = $self->regcomp($kid, 21, $extended);
+ ($re, $quote) = $self->regcomp($kid, 21);
}
if ($have_kid and $kid->name eq 'regcomp') {
my $matchop = $kid->first;
}
sub pp_match { matchop(@_, "m", "/") }
-sub pp_pushre { matchop(@_, "m", "/") }
sub pp_qr { matchop(@_, "qr", "") }
sub pp_runcv { unop(@_, "__SUB__"); }
sub pp_split {
- maybe_targmy(@_, \&split);
-}
-sub split {
my $self = shift;
my($op, $cx) = @_;
my($kid, @exprs, $ary, $expr);
+ my $stacked = $op->flags & OPf_STACKED;
+
$kid = $op->first;
+ $kid = $kid->sibling if $kid->name eq 'regcomp';
+ for (; !null($kid); $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 6);
+ }
- # For our kid (an OP_PUSHRE), pmreplroot is never actually the
- # root of a replacement; it's either empty, or abused to point to
- # the GV for an array we split into (an optimization to save
- # assignment overhead). Depending on whether we're using ithreads,
- # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
- # figures out for us which it is.
- my $replroot = $kid->pmreplroot;
- my $gv = 0;
- my $stacked = $op->flags & OPf_STACKED;
- if (ref($replroot) eq "B::GV") {
- $gv = $replroot;
- } elsif (!ref($replroot) and $replroot > 0) {
- $gv = $self->padval($replroot);
- } elsif ($kid->targ) {
- $ary = $self->padname($kid->targ)
- } elsif ($stacked) {
- $ary = $self->deparse($op->last, 7);
- }
- $ary = $self->maybe_local(@_,
+ unshift @exprs, $self->matchop($op, $cx, "m", "/");
+
+ if ($op->private & OPpSPLIT_ASSIGN) {
+ # With C<@array = split(/pat/, str);>,
+ # array is stored in split's pmreplroot; either
+ # as an integer index into the pad (for a lexical array)
+ # or as GV for a package array (which will be a pad index
+ # on threaded builds)
+ # With my/our @array = split(/pat/, str), the array is instead
+ # accessed via an extra padav/rv2av op at the end of the
+ # split's kid ops.
+
+ if ($stacked) {
+ $ary = pop @exprs;
+ }
+ else {
+ if ($op->private & OPpSPLIT_LEX) {
+ $ary = $self->padname($op->pmreplroot);
+ }
+ else {
+ # union with op_pmtargetoff, op_pmtargetgv
+ my $gv = $op->pmreplroot;
+ $gv = $self->padval($gv) if !ref($gv);
+ $ary = $self->maybe_local(@_,
$self->stash_variable('@',
$self->gv_name($gv),
$cx))
- if $gv;
-
- # Skip the last kid when OPf_STACKED is set, since it is the array
- # on the left.
- for (; !null($stacked ? $kid->sibling : $kid); $kid = $kid->sibling) {
- push @exprs, $self->deparse($kid, 6);
+ }
+ if ($op->private & OPpLVAL_INTRO) {
+ $ary = $op->private & OPpSPLIT_LEX ? "my $ary" : "local $ary";
+ }
+ }
}
# handle special case of split(), and split(' ') that compiles to /\s+/
- # Under 5.10, the reflags may be undef if the split regexp isn't a constant
- # Under 5.17.5-5.17.9, the special flag is on split itself.
- $kid = $op->first;
- if ( $op->flags & OPf_SPECIAL
- or (
- $kid->flags & OPf_SPECIAL
- and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
- : ($kid->reflags || 0) & RXf_SKIPWHITE()
- )
- )
- ) {
- $exprs[0] = "' '";
- }
+ $exprs[0] = q{' '} if ($op->reflags // 0) & RXf_SKIPWHITE();
$expr = "split(" . join(", ", @exprs) . ")";
if ($ary) {
$repl = $self->dq($repl);
}
}
- my $extended = ($pmflags & PMf_EXTENDED);
if (not null my $code_list = $op->code_list) {
- $re = $self->code_list($code_list, $extended);
+ $re = $self->code_list($code_list);
} elsif (null $kid) {
- my $unbacked = re_unback($op->precomp);
- if ($extended) {
- $re = re_uninterp_extended(escape_extended_re($unbacked));
- }
- else {
- $re = re_uninterp(escape_str($unbacked));
- }
+ $re = re_uninterp(escape_re(re_unback($op->precomp)));
} else {
- ($re) = $self->regcomp($kid, 1, $extended);
+ ($re) = $self->regcomp($kid, 1);
}
$flags .= "r" if $pmflags & PMf_NONDESTRUCT;
$flags .= "e" if $pmflags & PMf_EVAL;
: &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] : ";
+ my $def = $self->deparse($op->first, 7);
+ $def = "($def)" if $op->first->flags & OPf_PARENS;
+ $expr .= $self->deparse($op->first, $cx);
+ return $expr;
+}
+
+
1;
__END__
=item $[
Takes a number, the value of the array base $[.
-Cannot be non-zero on Perl 5.15.3 or later.
+Obsolete: cannot be non-zero.
=item bytes
=item *
-In Perl 5.20 and earlier, the only pragmas to
+The only pragmas to
be completely supported are: C<use warnings>,
C<use strict>, C<use bytes>, C<use integer>
-and C<use feature>. (C<$[>, which
-behaves like a pragma, is also supported.)
+and C<use feature>.
Excepting those listed above, we're currently unable to guarantee that
B::Deparse will produce a pragma at the correct point in the program.
(such as by over-riding keywords, overloading constants or whatever)
then the output code might not work as intended.
-This is the most serious problem in Perl 5.20 and earlier. Fixing this
-required internal changes in Perl 5.22.
-
=item *
Some constants don't print correctly either with or without B<-d>.
=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.
There are probably many more bugs on non-ASCII platforms (EBCDIC).
-=item *
-
-Prior to Perl 5.22, lexical C<my> subroutines were not deparsed properly.
-They were emitted as pure declarations, sometimes in the wrong place.
-Lexical C<state> subroutines were not deparsed at all.
-
=back
=head1 AUTHOR
https://perl5.git.perl.org / perl5.git / blobdiff