summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/B
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2016-04-05 22:27:26 +0000
committerKarl Berry <karl@freefriends.org>2016-04-05 22:27:26 +0000
commitb56b320b5e2515160073fa1b469514002688fe11 (patch)
tree965a7100c5e45fca8ec803d22b8b6ce14fca4633 /Master/tlpkg/tlperl/lib/B
parentd26c206452d2e285c3bbf949f34011e4a55fd8f9 (diff)
tlperl 5.22.1 from siep
git-svn-id: svn://tug.org/texlive/trunk@40252 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/B')
-rw-r--r--Master/tlpkg/tlperl/lib/B/Concise.pm249
-rw-r--r--Master/tlpkg/tlperl/lib/B/Debug.pm25
-rw-r--r--Master/tlpkg/tlperl/lib/B/Deparse.pm1717
-rw-r--r--Master/tlpkg/tlperl/lib/B/Op_private.pm836
-rw-r--r--Master/tlpkg/tlperl/lib/B/Showlex.pm44
5 files changed, 2280 insertions, 591 deletions
diff --git a/Master/tlpkg/tlperl/lib/B/Concise.pm b/Master/tlpkg/tlperl/lib/B/Concise.pm
index 6c818a4e463..311e0e738a9 100644
--- a/Master/tlpkg/tlperl/lib/B/Concise.pm
+++ b/Master/tlpkg/tlperl/lib/B/Concise.pm
@@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp
use Exporter (); # use #5
-our $VERSION = "0.992";
+our $VERSION = "0.996";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw( set_style set_style_standard add_callback
concise_subref concise_cv concise_main
@@ -400,7 +400,8 @@ my $lastnext; # remembers op-chain, used to insert gotos
my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
- 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#");
+ 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#",
+ 'METHOP' => '.', UNOP_AUX => '+');
no warnings 'qw'; # "Possible attempt to put comments..."; use #7
my @linenoise =
@@ -471,7 +472,12 @@ sub walk_topdown {
}
}
if (class($op) eq "PMOP") {
- my $maybe_root = $op->pmreplroot;
+ my $maybe_root = $op->code_list;
+ if ( ref($maybe_root) and $maybe_root->isa("B::OP")
+ and not $op->flags & OPf_KIDS) {
+ walk_topdown($maybe_root, $sub, $level + 1);
+ }
+ $maybe_root = $op->pmreplroot;
if (ref($maybe_root) and $maybe_root->isa("B::OP")) {
# It really is the root of the replacement, not something
# else stored here for lack of space elsewhere
@@ -527,29 +533,15 @@ sub sequence {
for (; $$op; $op = $op->next) {
last if exists $sequence_num{$$op};
my $name = $op->name;
- if ($name =~ /^(null|scalar|lineseq|scope)$/) {
- next if $oldop and $ {$op->next};
- } else {
- $sequence_num{$$op} = $seq_max++;
- if (class($op) eq "LOGOP") {
- my $other = $op->other;
- $other = $other->next while $other->name eq "null";
- sequence($other);
- } elsif (class($op) eq "LOOP") {
- my $redoop = $op->redoop;
- $redoop = $redoop->next while $redoop->name eq "null";
- sequence($redoop);
- my $nextop = $op->nextop;
- $nextop = $nextop->next while $nextop->name eq "null";
- sequence($nextop);
- my $lastop = $op->lastop;
- $lastop = $lastop->next while $lastop->name eq "null";
- sequence($lastop);
- } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
- my $replstart = $op->pmreplstart;
- $replstart = $replstart->next while $replstart->name eq "null";
- sequence($replstart);
- }
+ $sequence_num{$$op} = $seq_max++;
+ if (class($op) eq "LOGOP") {
+ sequence($op->other);
+ } elsif (class($op) eq "LOOP") {
+ sequence($op->redoop);
+ sequence( $op->nextop);
+ sequence($op->lastop);
+ } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
+ sequence($op->pmreplstart);
}
$oldop = $op;
}
@@ -592,73 +584,13 @@ sub fmt_line { # generate text-line for op.
return $text; # suppress empty lines
}
-our %priv; # used to display each opcode's BASEOP.op_private values
-
-$priv{$_}{128} = "LVINTRO"
- for qw(pos substr vec threadsv gvsv rv2sv rv2hv rv2gv rv2av rv2arylen
- aelem helem aslice hslice padsv padav padhv enteriter entersub
- padrange pushmark);
-$priv{$_}{64} = "REFC" for qw(leave leavesub leavesublv leavewrite);
-$priv{$_}{128} = "LV" for qw(leave leaveloop);
-@{$priv{aassign}}{32,64} = qw(STATE COMMON);
-@{$priv{sassign}}{32,64,128} = qw(STATE BKWARD CV2GV);
-$priv{$_}{64} = "RTIME" for qw(match subst substcont qr);
-@{$priv{$_}}{1,2,4,8,16,64} = qw(<UTF >UTF IDENT SQUASH DEL COMPL GROWS)
- for qw(trans transr);
-$priv{repeat}{64} = "DOLIST";
-$priv{leaveloop}{64} = "CONT";
-@{$priv{$_}}{32,64,96} = qw(DREFAV DREFHV DREFSV)
- for qw(rv2gv rv2sv padsv aelem helem);
-$priv{$_}{16} = "STATE" for qw(padav padhv padsv);
-@{$priv{rv2gv}}{4,16} = qw(NOINIT FAKE);
-@{$priv{entersub}}{1,4,16,32,64} = qw(INARGS TARG DBG DEREF);
-@{$priv{rv2cv}}{1,8,128} = qw(CONST AMPER NO());
-$priv{gv}{32} = "EARLYCV";
-$priv{$_}{16} = "LVDEFER" for qw(aelem helem);
-$priv{$_}{16} = "OURINTR" for qw(gvsv rv2sv rv2av rv2hv r2gv enteriter);
-$priv{$_}{8} = "LVSUB"
- for qw(rv2av rv2gv rv2hv padav padhv aelem helem aslice hslice
- av2arylen keys rkeys substr pos vec);
-$priv{$_}{4} = "SLICEWARN"
- for qw(rv2hv rv2av padav padhv hslice aslice);
-@{$priv{$_}}{32,64} = qw(BOOL BOOL?) for qw(rv2hv padhv);
-$priv{substr}{16} = "REPL1ST";
-$priv{$_}{16} = "TARGMY"
- for map(($_,"s$_"), qw(chop chomp)),
- map(($_,"i_$_"), qw(postinc postdec multiply divide modulo add
- subtract negate)),
- qw(pow concat stringify left_shift right_shift bit_and bit_xor
- bit_or complement atan2 sin cos rand exp log sqrt int hex oct
- abs length index rindex sprintf ord chr crypt quotemeta join
- push unshift flock chdir chown chroot unlink chmod utime rename
- link symlink mkdir rmdir wait waitpid system exec kill getppid
- getpgrp setpgrp getpriority setpriority time sleep);
-$priv{$_}{4} = "REVERSED" for qw(enteriter iter);
-@{$priv{const}}{2,4,8,16,64} = qw(NOVER SHORT STRICT ENTERED BARE);
-$priv{$_}{64} = "LINENUM" for qw(flip flop);
-$priv{list}{64} = "GUESSED";
-$priv{delete}{64} = "SLICE";
-$priv{exists}{64} = "SUB";
-@{$priv{sort}}{1,2,4,8,16,32,64} = qw(NUM INT REV INPLACE DESC QSORT STABLE);
-$priv{reverse}{8} = "INPLACE";
-$priv{threadsv}{64} = "SVREFd";
-@{$priv{$_}}{16,32,64,128} = qw(INBIN INCR OUTBIN OUTCR)
- for qw(open backtick);
-$priv{$_}{32} = "HUSH" for qw(nextstate dbstate);
-$priv{$_}{2} = "FTACCESS"
- for qw(ftrread ftrwrite ftrexec fteread ftewrite fteexec);
-@{$priv{entereval}}{2,4,8,16} = qw(HAS_HH UNI BYTES COPHH);
-@{$priv{$_}}{4,8,16} = qw(FTSTACKED FTSTACKING FTAFTERt)
- for qw(ftrread ftrwrite ftrexec fteread ftewrite fteexec ftis fteowned
- ftrowned ftzero ftsize ftmtime ftatime ftctime ftsock ftchr
- ftblk ftfile ftdir ftpipe ftlink ftsuid ftsgid ftsvtx fttty
- fttext ftbinary);
-$priv{$_}{2} = "GREPLEX"
- for qw(mapwhile mapstart grepwhile grepstart);
-$priv{$_}{128} = "+1" for qw(caller wantarray runcv);
-@{$priv{coreargs}}{1,2,64,128} = qw(DREF1 DREF2 $MOD MARK);
-$priv{$_}{128} = "UTF" for qw(last redo next goto dump);
-$priv{split}{128} = "IMPLIM";
+
+
+# use require rather than use here to avoid disturbing tests that dump
+# BEGIN blocks
+require B::Op_private;
+
+
our %hints; # used to display each COP's op_hints values
@@ -688,9 +620,61 @@ sub _flags {
return join(",", @s);
}
+# return a string like 'LVINTRO,1' for the op $name with op_private
+# value $x
+
sub private_flags {
my($name, $x) = @_;
- _flags($priv{$name}, $x);
+ my $entry = $B::Op_private::bits{$name};
+ return $x ? "$x" : '' unless $entry;
+
+ my @flags;
+ my $bit;
+ for ($bit = 7; $bit >= 0; $bit--) {
+ next unless exists $entry->{$bit};
+ my $e = $entry->{$bit};
+ if (ref($e) eq 'HASH') {
+ # bit field
+
+ my ($bitmin, $bitmax, $bitmask, $enum, $label) =
+ @{$e}{qw(bitmin bitmax bitmask enum label)};
+ $bit = $bitmin;
+ next if defined $label && $label eq '-'; # display as raw number
+
+ my $val = $x & $bitmask;
+ $x &= ~$bitmask;
+ $val >>= $bitmin;
+
+ if (defined $enum) {
+ # try to convert numeric $val into symbolic
+ my @enum = @$enum;
+ while (@enum) {
+ my $ix = shift @enum;
+ my $name = shift @enum;
+ my $label = shift @enum;
+ if ($val == $ix) {
+ $val = $label;
+ last;
+ }
+ }
+ }
+ next if $val eq '0'; # don't display anonymous zero values
+ push @flags, defined $label ? "$label=$val" : $val;
+
+ }
+ else {
+ # flag bit
+ my $label = $B::Op_private::labels{$e};
+ next if defined $label && $label eq '-'; # display as raw number
+ if ($x & (1<<$bit)) {
+ $x -= (1<<$bit);
+ push @flags, $label;
+ }
+ }
+ }
+
+ push @flags, $x if $x; # display unknown bits numerically
+ return join ",", @flags;
}
sub hints_flags {
@@ -779,23 +763,35 @@ sub concise_op {
$h{class} = class($op);
$h{extarg} = $h{targ} = $op->targ;
$h{extarg} = "" unless $h{extarg};
- if ($h{name} eq "null" and $h{targ}) {
- # targ holds the old type
- $h{exname} = "ex-" . substr(ppname($h{targ}), 3);
+ $h{privval} = $op->private;
+ # for null ops, targ holds the old type
+ my $origname = $h{name} eq "null" && $h{targ}
+ ? substr(ppname($h{targ}), 3)
+ : $h{name};
+ $h{private} = private_flags($origname, $op->private);
+ if ($op->folded) {
+ $h{private} &&= "$h{private},";
+ $h{private} .= "FOLD";
+ }
+
+ if ($h{name} ne $origname) { # a null op
+ $h{exname} = "ex-$origname";
$h{extarg} = "";
- } elsif ($op->name =~ /^leave(sub(lv)?|write)?$/) {
- # targ potentially holds a reference count
- if ($op->private & 64) {
- my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
- $h{targarglife} = $h{targarg} = "$h{targ} $refs";
- }
+ } elsif ($h{private} =~ /\bREFC\b/) {
+ # targ holds a reference count
+ my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
+ $h{targarglife} = $h{targarg} = "$h{targ} $refs";
} elsif ($h{targ}) {
- my $count = $h{name} eq 'padrange' ? ($op->private & 127) : 1;
+ my $count = $h{name} eq 'padrange'
+ ? ($op->private & $B::Op_private::defines{'OPpPADRANGE_COUNTMASK'})
+ : 1;
my (@targarg, @targarglife);
for my $i (0..$count-1) {
my ($targarg, $targarglife);
my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}+$i];
- if (defined $padname and class($padname) ne "SPECIAL") {
+ if (defined $padname and class($padname) ne "SPECIAL" and
+ $padname->LEN)
+ {
$targarg = $padname->PVX;
if ($padname->FLAGS & SVf_FAKE) {
# These changes relate to the jumbo closure fix.
@@ -892,16 +888,37 @@ sub concise_op {
elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix;
- my $preferpv = $h{name} eq "method_named";
if ($h{class} eq "PADOP" or !${$op->sv}) {
my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx];
- $h{arg} = "[" . concise_sv($sv, \%h, $preferpv) . "]";
+ $h{arg} = "[" . concise_sv($sv, \%h, 0) . "]";
$h{targarglife} = $h{targarg} = "";
} else {
- $h{arg} = "(" . concise_sv($op->sv, \%h, $preferpv) . ")";
+ $h{arg} = "(" . concise_sv($op->sv, \%h, 0) . ")";
}
}
}
+ elsif ($h{class} eq "METHOP") {
+ my $prefix = '';
+ if ($h{name} eq 'method_redir' or $h{name} eq 'method_redir_super') {
+ my $rclass_sv = $op->rclass;
+ $rclass_sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$rclass_sv]
+ unless ref $rclass_sv;
+ $prefix .= 'PACKAGE "'.$rclass_sv->PV.'", ';
+ }
+ if ($h{name} ne "method") {
+ if (${$op->meth_sv}) {
+ $h{arg} = "($prefix" . concise_sv($op->meth_sv, \%h, 1) . ")";
+ } else {
+ my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->targ];
+ $h{arg} = "[$prefix" . concise_sv($sv, \%h, 1) . "]";
+ $h{targarglife} = $h{targarg} = "";
+ }
+ }
+ }
+ elsif ($h{class} eq "UNOP_AUX") {
+ $h{arg} = "(" . $op->string($curcv) . ")";
+ }
+
$h{seq} = $h{hyphseq} = seq($op);
$h{seq} = "" if $h{seq} eq "-";
$h{opt} = $op->opt;
@@ -916,12 +933,6 @@ sub concise_op {
$h{classsym} = $opclass{$h{class}};
$h{flagval} = $op->flags;
$h{flags} = op_flags($op->flags);
- $h{privval} = $op->private;
- $h{private} = private_flags($h{name}, $op->private);
- if ($op->folded) {
- $h{private} &&= "$h{private},";
- $h{private} .= "FOLD";
- }
if ($op->can("hints")) {
$h{hintsval} = $op->hints;
$h{hints} = hints_flags($h{hintsval});
@@ -1046,8 +1057,7 @@ sub tree {
# to update the corresponding magic number in the next line.
# Remember, this needs to stay the last things in the module.
-# Why is this different for MacOS? Does it matter?
-my $cop_seq_mnum = $^O eq 'MacOS' ? 12 : 11;
+my $cop_seq_mnum = 16;
$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
1;
@@ -1377,6 +1387,7 @@ B:: namespace that represents the ops in your Perl code.
0 OP (aka BASEOP) An OP with no children
1 UNOP An OP with one child
+ + UNOP_AUX A UNOP with auxillary fields
2 BINOP An OP with two children
| LOGOP A control branch OP
@ LISTOP An OP that could have lots of children
@@ -1386,6 +1397,7 @@ B:: namespace that represents the ops in your Perl code.
{ LOOP An OP that holds pointers for a loop
; COP An OP that marks the start of a statement
# PADOP An OP with a GV on the pad
+ . METHOP An OP with method call info
=head2 OP flags abbreviations
@@ -1413,10 +1425,7 @@ Private flags, if any are set for an opcode, are displayed after a '/'
They're opcode specific, and occur less often than the public ones, so
they're represented by short mnemonics instead of single-chars; see
-F<op.h> for gory details, or try this quick 2-liner:
-
- $> perl -MB::Concise -de 1
- DB<1> |x \%B::Concise::priv
+B::Op_private and F<regen/op_private> for more details.
=head1 FORMATTING SPECIFICATIONS
diff --git a/Master/tlpkg/tlperl/lib/B/Debug.pm b/Master/tlpkg/tlperl/lib/B/Debug.pm
index c4a1a33afa6..fd66405bac3 100644
--- a/Master/tlpkg/tlperl/lib/B/Debug.pm
+++ b/Master/tlpkg/tlperl/lib/B/Debug.pm
@@ -1,6 +1,6 @@
package B::Debug;
-our $VERSION = '1.19';
+our $VERSION = '1.23';
use strict;
require 5.006;
@@ -36,7 +36,11 @@ sub _printop {
my $op = shift;
my $addr = ${$op} ? $op->ppaddr : '';
$addr =~ s/^PL_ppaddr// if $addr;
- return sprintf "0x%08x %6s %s", ${$op}, ${$op} ? class($op) : '', $addr;
+ if (${$op}) {
+ return sprintf "0x%08x %6s %s", ${$op}, class($op), $addr;
+ } else {
+ return sprintf "0x%x %6s %s", ${$op}, '', $addr;
+ }
}
sub B::OP::debug {
@@ -151,6 +155,18 @@ sub B::SVOP::debug {
$op->sv->debug;
}
+sub B::METHOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ if (${$op->first}) {
+ printf "\top_first\t0x%x\n", ${$op->first};
+ $op->first->debug;
+ } else {
+ printf "\top_meth_sv\t0x%x\n", ${$op->meth_sv};
+ $op->meth_sv->debug;
+ }
+}
+
sub B::PVOP::debug {
my ($op) = @_;
$op->B::OP::debug();
@@ -361,7 +377,7 @@ EOT
sub B::SPECIAL::debug {
my $sv = shift;
my $i = ref $sv ? $$sv : 0;
- print exists $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n";
+ print defined $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n";
}
sub B::PADLIST::debug {
@@ -376,6 +392,7 @@ EOT
sub compile {
my $order = shift;
B::clearsym();
+ $DB::single = 1 if defined &DB::DB;
if ($order && $order eq "exec") {
return sub { walkoptree_exec(main_start, "debug") }
} else {
@@ -413,7 +430,7 @@ Reini Urban C<rurban@cpan.org>
=head1 LICENSE
Copyright (c) 1996, 1997 Malcolm Beattie
-Copyright (c) 2008, 2010, 2013 Reini Urban
+Copyright (c) 2008, 2010, 2013, 2014 Reini Urban
This program is free software; you can redistribute it and/or modify
it under the terms of either:
diff --git a/Master/tlpkg/tlperl/lib/B/Deparse.pm b/Master/tlpkg/tlperl/lib/B/Deparse.pm
index e7eb8cf90d3..d4c6f6061ac 100644
--- a/Master/tlpkg/tlperl/lib/B/Deparse.pm
+++ b/Master/tlpkg/tlperl/lib/B/Deparse.pm
@@ -11,16 +11,42 @@ package B::Deparse;
use Carp;
use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
- OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
+ OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPf_PARENS
OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
- OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
- OPpSORT_REVERSE
+ 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
+ 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);
-$VERSION = '1.26';
+ 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.35';
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
@@ -32,9 +58,11 @@ BEGIN {
# 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
+ RXf_PMf_CHARSET RXf_PMf_KEEPCOPY CVf_ANONCONST
CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
- PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES)) {
+ PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES
+ OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV
+ OPpLVREF_CV OPpLVREF_ELEM SVpad_STATE)) {
eval { import B $_ };
no strict 'refs';
*{$_} = sub () {0} unless *{$_}{CODE};
@@ -205,7 +233,11 @@ BEGIN {
# 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
@@ -221,8 +253,9 @@ BEGIN {
# curcvlex:
# Cached hash of lexical variables for curcv: keys are
# names prefixed with "m" or "o" (representing my/our), and
-# each value is an array of pairs, indicating the cop_seq of scopes
-# in which a var of that name is valid.
+# each value is an array with two elements indicating the cop_seq
+# of scopes in which a var of that name is valid and a third ele-
+# ment referencing the pad name.
#
# curcop:
# COP for statement being deparsed
@@ -231,8 +264,10 @@ BEGIN {
# 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
+# 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
@@ -246,12 +281,12 @@ BEGIN {
# 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.
#
+# in_refgen
+# True when deparsing the argument to \.
+#
# parens: -p
# linenums: -l
# unquote: -q
@@ -314,9 +349,19 @@ BEGIN {
# \f - flush left (no indent)
# \cK - kill following semicolon, if any
+# Semicolon handling:
+# - Individual statements are not deparsed with trailing semicolons.
+# (If necessary, \cK is tacked on to the end.)
+# - Whatever code joins statements together or emits them (lineseq,
+# scopeop, deparse_root) is responsible for adding semicolons where
+# necessary.
+# - use statements are deparsed with trailing semicolons because they are
+# immediately concatenated with the following statement.
+# - indent() removes semicolons wherever it sees \cK.
-BEGIN { for (qw[ const stringify rv2sv list glob pushmark null]) {
+BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
+ nextstate dbstate rv2av rv2hv helem custom ]) {
eval "sub OP_\U$_ () { " . opnumber($_) . "}"
}}
@@ -351,9 +396,6 @@ sub _pessimise_walk {
type => OP_PUSHMARK,
name => 'pushmark',
private => ($op->private & OPpLVAL_INTRO),
- next => ($op->flags & OPf_SPECIAL)
- ? $op->sibling->first
- : $op->sibling,
};
}
@@ -434,8 +476,9 @@ sub null {
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;
@@ -444,28 +487,91 @@ sub todo {
} 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;
- }
+ push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form, $name];
}
sub next_todo {
my $self = shift;
my $ent = shift @{$self->{'subs_todo'}};
my $cv = $ent->[1];
+ if (ref $ent->[3]) { # lexical sub
+ my @text;
+
+ # 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};
+ }
+
+ # Now emit the sub itself.
+ my $padname = $ent->[3];
+ my $flags = $padname->FLAGS;
+ push @text,
+ !$cv || $ent->[0] <= $padname->COP_SEQ_RANGE_LOW
+ ? $self->keyword($flags & SVpad_OUR
+ ? "our"
+ : $flags & SVpad_STATE
+ ? "state"
+ : "my") . " "
+ : "";
+ # 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;
+ if ($cv) {
+ # my sub foo { }
+ push @text, " " . $self->deparse_sub($cv);
+ $text[-1] =~ s/ ;$/;/;
+ }
+ else {
+ # my sub foo;
+ push @text, ";\n";
+ }
+ return join "", @text;
+ }
my $gv = $cv->GV;
- my $name = $self->gv_name($gv);
+ my $name = $ent->[3] // $self->gv_name($gv);
if ($ent->[2]) {
- return "format $name =\n"
+ return $self->keyword("format") . " $name =\n"
. $self->deparse_format($ent->[1]). "\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 $use_dec;
+ $use_dec =~ s/^(use|no)\b/$self->keyword($1)/e;
}
}
my $l = '';
@@ -475,16 +581,29 @@ sub next_todo {
$l = "\n\f#line $line \"$file\"\n";
}
my $p = '';
+ my $stash;
if (class($cv->STASH) ne "SPECIAL") {
- my $stash = $cv->STASH->NAME;
+ $stash = $cv->STASH->NAME;
if ($stash ne $self->{'curstash'}) {
- $p = "package $stash;\n";
+ $p = $self->keyword("package") . " $stash;\n";
$name = "$self->{'curstash'}::$name" unless $name =~ /::/;
$self->{'curstash'} = $stash;
}
- $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
}
- return "${p}${l}sub $name " . $self->deparse_sub($cv);
+ if ($use_dec) {
+ return "$p$l$use_dec";
+ }
+ if ( $name !~ /::/ and $self->lex_in_scope("&$name")
+ || $self->lex_in_scope("&$name", 1) )
+ {
+ $name = "$self->{'curstash'}::$name";
+ } elsif (defined $stash) {
+ $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
+ }
+ my $ret = "${p}${l}" . $self->keyword("sub") . " $name "
+ . $self->deparse_sub($cv);
+ $self->{'subs_declared'}{$name} = 1;
+ return $ret;
}
}
@@ -537,7 +656,7 @@ sub begin_is_use {
}
$constop = $constop->sibling;
return if $constop->name ne "method_named";
- return if $self->const_sv($constop)->PV ne "VERSION";
+ return if $self->meth_sv($constop)->PV ne "VERSION";
}
$lineseq = $version_op->sibling;
@@ -556,7 +675,7 @@ sub begin_is_use {
return unless $self->const_sv($svop)->PV eq $module;
# Pull out the arguments
- for ($svop=$svop->sibling; $svop->name ne "method_named";
+ for ($svop=$svop->sibling; index($svop->name, "method_") != 0;
$svop = $svop->sibling) {
$args .= ", " if length($args);
$args .= $self->deparse($svop, 6);
@@ -565,7 +684,7 @@ sub begin_is_use {
my $use = 'use';
my $method_named = $svop;
return if $method_named->name ne "method_named";
- my $method_name = $self->const_sv($method_named)->PV;
+ my $method_name = $self->meth_sv($method_named)->PV;
if ($method_name eq "unimport") {
$use = 'no';
@@ -608,8 +727,31 @@ sub stash_subs {
}++;
my %stash = svref_2object($stash)->ARRAY;
while (my ($key, $val) = each %stash) {
- my $class = class($val);
- if ($class eq "PV") {
+ my $flags = $val->FLAGS;
+ if ($flags & SVf_ROK) {
+ # 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, 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
# to find out if it belongs here is to see if the AUTOLOAD
# (if any) for the stash was defined in one of our files.
@@ -619,20 +761,9 @@ sub stash_subs {
my $AF = $A->FILE;
next unless $AF eq $0 || exists $self->{'files'}{$AF};
}
- push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
- } elsif ($class eq "IV" && !($val->FLAGS & SVf_ROK)) {
- # Just a name. As above.
- # But skip proxy constant subroutines, as some form of perl-space
- # visible code must have created them, be it a use statement, or
- # some direct symbol-table manipulation code that we will Deparse
- my $A = $stash{"AUTOLOAD"};
- if (defined ($A) && class($A) eq "GV" && defined($A->CV)
- && class($A->CV) eq "CV") {
- my $AF = $A->FILE;
- next unless $AF eq $0 || exists $self->{'files'}{$AF};
- }
- push @{$self->{'protos_todo'}}, [$pack . $key, undef];
- } elsif ($class eq "GV") {
+ push @{$self->{'protos_todo'}},
+ [$pack . $key, $flags & SVf_POK ? $val->PV: undef];
+ } elsif (class($val) eq "GV") {
if (class(my $cv = $val->CV) ne "SPECIAL") {
next if $self->{'subs_done'}{$$val}++;
next if $$val != ${$cv->GV}; # Ignore imposters
@@ -655,8 +786,12 @@ sub print_protos {
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;
@@ -781,8 +916,13 @@ sub compile {
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__"}) =
@@ -801,8 +941,26 @@ sub compile {
my $root = main_root;
local $B::overlay = {};
unless (null $root) {
- $self->pessimise($root, main_start);
- print $self->indent($self->deparse_root($root)), "\n";
+ $self->pad_subs($self->{'curcv'});
+ # 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'}})) {
@@ -815,9 +973,9 @@ sub compile {
my $laststash = defined $self->{'curcop'}
? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
if (defined *{$laststash."::DATA"}{IO}) {
- print "package $laststash;\n"
+ print $self->keyword("package") . " $laststash;\n"
unless $laststash eq $self->{'curstash'};
- print "__DATA__\n";
+ print $self->keyword("__DATA__") . "\n";
print readline(*{$laststash."::DATA"});
}
}
@@ -829,6 +987,7 @@ sub coderef2text {
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)));
}
@@ -964,6 +1123,9 @@ sub deparse {
sub indent {
my $self = shift;
my $txt = shift;
+ # \cK also swallows a preceding line break when followed by a
+ # semicolon.
+ $txt =~ s/\n\cK;//g;
my @lines = split(/\n/, $txt);
my $leader = "";
my $level = 0;
@@ -992,6 +1154,73 @@ sub indent {
return join("\n", @lines);
}
+sub pad_subs {
+ my ($self, $cv) = @_;
+ my $padlist = $cv->PADLIST;
+ 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, $_]
+ # [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
+ # declared and defined at once: my sub foo { ... }
+ push @todo, [$low, $protocv, 0, $_];
+ }
+ else {
+ # declared and defined separately: my sub f; sub f { ... }
+ push @todo, [$low, undef, 0, $_];
+ push @todo, [$outseq, $protocv, 0, $_]
+ if $defined_in_this_sub;
+ }
+ }
+ }}
+ @{$self->{'subs_todo'}} =
+ sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo
+}
+
sub deparse_sub {
my $self = shift;
my $cv = shift;
@@ -1002,11 +1231,12 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
if ($cv->FLAGS & SVf_POK) {
$proto = "(". $cv->PV . ") ";
}
- if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
+ if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ANONCONST)) {
$proto .= ": ";
$proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
$proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
$proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
+ $proto .= "const " if $cv->CvFLAGS & CVf_ANONCONST;
}
local($self->{'curcv'}) = $cv;
@@ -1017,6 +1247,7 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
my $root = $cv->ROOT;
local $B::overlay = {};
if (not null $root) {
+ $self->pad_subs($cv);
$self->pessimise($root, $cv->START);
my $lineseq = $root->first;
if ($lineseq->name eq "lineseq") {
@@ -1191,28 +1422,60 @@ sub maybe_parens_func {
}
}
+sub find_our_type {
+ my ($self, $name) = @_;
+ $self->populate_curcvlex() if !defined $self->{'curcvlex'};
+ my $seq = $self->{'curcop'} ? $self->{'curcop'}->cop_seq : 0;
+ for my $a (@{$self->{'curcvlex'}{"o$name"}}) {
+ my ($st, undef, $padname) = @$a;
+ if ($st >= $seq && $padname->FLAGS & SVpad_TYPED) {
+ return $padname->SvSTASH->NAME;
+ }
+ }
+ return '';
+}
+
sub maybe_local {
my $self = shift;
my($op, $cx, $text) = @_;
- my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
- if ($op->private & (OPpLVAL_INTRO|$our_intro)
- and not $self->{'avoid_local'}{$$op}) {
- my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
- if( $our_local eq 'our' ) {
+ my $name = $op->name;
+ my $our_intro = ($name =~ /^(?:(?:gv|rv2)[ash]v|split|refassign
+ |lv(?:av)?ref)$/x)
+ ? OPpOUR_INTRO
+ : 0;
+ my $lval_intro = $name eq 'split' ? 0 : OPpLVAL_INTRO;
+ # The @a in \(@a) isn't in ref context, but only when the
+ # parens are there.
+ my $need_parens = $self->{'in_refgen'} && $name =~ /[ah]v\z/
+ && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
+ if ((my $priv = $op->private) & ($lval_intro|$our_intro)) {
+ my @our_local;
+ push @our_local, "local" if $priv & $lval_intro;
+ push @our_local, "our" if $priv & $our_intro;
+ my $our_local = join " ", map $self->keyword($_), @our_local;
+ if( $our_local[-1] eq 'our' ) {
if ( $text !~ /^\W(\w+::)*\w+\z/
and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
) {
die "Unexpected our($text)\n";
}
$text =~ s/(\w+::)+//;
+
+ if (my $type = $self->find_our_type($text)) {
+ $our_local .= ' ' . $type;
+ }
}
- if (want_scalar($op)) {
+ return $need_parens ? "($text)" : $text
+ if $self->{'avoid_local'}{$$op};
+ if ($need_parens) {
+ return "$our_local($text)";
+ } elsif (want_scalar($op)) {
return "$our_local $text";
} else {
return $self->maybe_parens_func("$our_local", $text, $cx, 16);
}
} else {
- return $text;
+ return $need_parens ? "($text)" : $text;
}
}
@@ -1236,18 +1499,33 @@ sub padname_sv {
sub maybe_my {
my $self = shift;
- my($op, $cx, $text, $forbid_parens) = @_;
+ my($op, $cx, $text, $padname, $forbid_parens) = @_;
+ # The @a in \(@a) isn't in ref context, but only when the
+ # parens are there.
+ 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}) {
- my $my = $op->private & OPpPAD_STATE
- ? $self->keyword("state")
- : "my";
- if ($forbid_parens || want_scalar($op)) {
+ # Check $padname->FLAGS for statehood, rather than $op->private,
+ # because enteriter ops do not carry the flag.
+ my $my =
+ $self->keyword($padname->FLAGS & SVpad_STATE ? "state" : "my");
+ if ($padname->FLAGS & SVpad_TYPED) {
+ $my .= ' ' . $padname->SvSTASH->NAME;
+ }
+ if ($need_parens) {
+ return "$my($text)";
+ } elsif ($forbid_parens || want_scalar($op)) {
return "$my $text";
} else {
return $self->maybe_parens_func($my, $text, $cx, 16);
}
} else {
- return $text;
+ return $need_parens ? "($text)" : $text;
}
}
@@ -1257,7 +1535,8 @@ sub maybe_my {
sub AUTOLOAD {
if ($AUTOLOAD =~ s/^.*::pp_//) {
- warn "unexpected OP_".uc $AUTOLOAD;
+ warn "unexpected OP_".
+ ($_[1]->type == OP_CUSTOM ? "CUSTOM ($AUTOLOAD)" : uc $AUTOLOAD);
return "XXX";
} else {
die "Undefined subroutine $AUTOLOAD called";
@@ -1314,11 +1593,12 @@ sub scopeop {
my $top = $kid->first;
my $name = $top->name;
if ($name eq "and") {
- $name = "while";
+ $name = $self->keyword("while");
} elsif ($name eq "or") {
- $name = "until";
+ $name = $self->keyword("until");
} else { # no conditional -> while 1 or until 0
- return $self->deparse($top->first, 1) . " while 1";
+ return $self->deparse($top->first, 1) . " "
+ . $self->keyword("while") . " 1";
}
my $cond = $top->first;
my $body = $cond->sibling->first; # skip lineseq
@@ -1334,7 +1614,10 @@ sub scopeop {
}
if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
my $body = $self->lineseq($op, 0, @kids);
- return is_lexical_subs(@kids) ? $body : "do {\n\t$body\n\b}";
+ return is_lexical_subs(@kids)
+ ? $body
+ : ($self->lex_in_scope("&do") ? "CORE::do" : "do")
+ . " {\n\t$body\n\b}";
} else {
my $lineseq = $self->lineseq($op, $cx, @kids);
return (length ($lineseq) ? "$lineseq;" : "");
@@ -1359,8 +1642,10 @@ sub deparse_root {
push @kids, $kid;
}
$self->walk_lineseq($op, \@kids,
- sub { print $self->indent($_[0].';');
- print "\n" unless $_[1] == $#kids;
+ sub { return unless length $_[0];
+ print $self->indent($_[0].';');
+ print "\n"
+ unless $_[1] == $#kids;
});
}
@@ -1381,8 +1666,9 @@ sub walk_lineseq {
$i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
next;
}
- $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
- $expr =~ s/;\n?\z//;
+ my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2);
+ $expr2 =~ s/^sub :(?!:)/+sub :/; # statement label otherwise
+ $expr .= $expr2;
$callback->($expr, $i);
}
}
@@ -1397,9 +1683,14 @@ sub gv_name {
my $self = shift;
my $gv = shift;
my $raw = shift;
-Carp::confess() unless ref($gv) eq "B::GV";
- my $stash = $gv->STASH->NAME;
- my $name = $raw ? $gv->NAME : $gv->SAFENAME;
+#Carp::confess() unless ref($gv) eq "B::GV";
+ my $cv = $gv->FLAGS & SVf_ROK ? $gv->RV : 0;
+ my $stash = ($cv || $gv)->STASH->NAME;
+ my $name = $raw
+ ? $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME
+ : $cv
+ ? B::safename($cv->NAME_HEK || $cv->GV->NAME)
+ : $gv->SAFENAME;
if ($stash eq 'main' && $name =~ /^::/) {
$stash = '::';
}
@@ -1428,12 +1719,12 @@ sub stash_variable {
return "$prefix$name" if $name =~ /::/;
- unless ($prefix eq '$' || $prefix eq '@' || #'
+ 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}";
@@ -1448,6 +1739,41 @@ sub stash_variable {
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 {
@@ -1455,12 +1781,12 @@ 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
}
else {
- single_delim("q", "'", $name), 1;
+ single_delim("q", "'", $name, $self), 1;
}
}
@@ -1510,6 +1836,7 @@ sub populate_curcvlex {
next;
}
my $name = $ns[$i]->PVX;
+ next unless defined $name;
my ($seq_st, $seq_en) =
($ns[$i]->FLAGS & SVf_FAKE)
? (0, 999999)
@@ -1517,7 +1844,7 @@ sub populate_curcvlex {
push @{$self->{'curcvlex'}{
($ns[$i]->FLAGS & SVpad_OUR ? 'o' : 'm') . $name
- }}, [$seq_st, $seq_en];
+ }}, [$seq_st, $seq_en, $ns[$i]];
}
}
}
@@ -1560,11 +1887,13 @@ sub find_scope {
sub cop_subs {
my ($self, $op, $out_seq) = @_;
my $seq = $op->cop_seq;
- # 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
+ 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);
@@ -1576,10 +1905,24 @@ sub seq_subs {
#push @text, "# ($seq)\n";
return "" if !defined $seq;
+ my @pending;
while (scalar(@{$self->{'subs_todo'}})
and $seq > $self->{'subs_todo'}[0][0]) {
+ my $cv = $self->{'subs_todo'}[0][1];
+ # 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 = ref $self->{'subs_todo'}[0][3];
+ my $outside = !$lexical && $cv && $cv->OUTSIDE;
+ if (!$lexical and $cv
+ and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}})
+ {
+ push @pending, shift @{$self->{'subs_todo'}};
+ next;
+ }
push @text, $self->next_todo;
}
+ unshift @{$self->{'subs_todo'}}, @pending;
return @text;
}
@@ -1599,9 +1942,13 @@ sub pp_nextstate {
$self->{'curcop'} = $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, "package $stash;\n";
+ push @text, $self->keyword("package") . " $stash;\n";
$self->{'curstash'} = $stash;
}
@@ -1627,14 +1974,15 @@ sub pp_nextstate {
if (defined ($warning_bits) and
!defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
- push @text, declare_warnings($self->{'warnings'}, $warning_bits);
+ push @text,
+ $self->declare_warnings($self->{'warnings'}, $warning_bits);
$self->{'warnings'} = $warning_bits;
}
my $hints = $] < 5.008009 ? $op->private : $op->hints;
my $old_hints = $self->{'hints'};
if ($self->{'hints'} != $hints) {
- push @text, declare_hints($self->{'hints'}, $hints);
+ push @text, $self->declare_hints($self->{'hints'}, $hints);
$self->{'hints'} = $hints;
}
@@ -1661,14 +2009,15 @@ sub pp_nextstate {
my $bundle =
$feature::hint_bundles[$to >> $feature::hint_shift];
$bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12
- push @text, "no feature;\n",
- "use feature ':$bundle';\n";
+ push @text,
+ $self->keyword("no") . " feature ':all';\n",
+ $self->keyword("use") . " feature ':$bundle';\n";
}
}
}
if ($] > 5.009) {
- push @text, declare_hinthash(
+ push @text, $self->declare_hinthash(
$self->{'hinthash'}, $newhh,
$self->{indent_size}, $self->{hints},
);
@@ -1678,7 +2027,7 @@ sub pp_nextstate {
# 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.
- if ($self->{'linenums'}) {
+ if ($self->{'linenums'} && $cx != .5) { # $cx == .5 means in a format
push @text, "\f#line " . $op->line .
' "' . $op->file, qq'"\n';
}
@@ -1689,26 +2038,28 @@ sub pp_nextstate {
}
sub declare_warnings {
- my ($from, $to) = @_;
+ my ($self, $from, $to) = @_;
if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
- return "use warnings;\n";
+ return $self->keyword("use") . " warnings;\n";
}
elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
- return "no warnings;\n";
+ return $self->keyword("no") . " warnings;\n";
}
- return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n";
+ return "BEGIN {\${^WARNING_BITS} = \""
+ . join("", map { sprintf("\\x%02x", ord $_) } split "", $to)
+ . "\"}\n\cK";
}
sub declare_hints {
- my ($from, $to) = @_;
+ my ($self, $from, $to) = @_;
my $use = $to & ~$from;
my $no = $from & ~$to;
my $decls = "";
for my $pragma (hint_pragmas($use)) {
- $decls .= "use $pragma;\n";
+ $decls .= $self->keyword("use") . " $pragma;\n";
}
for my $pragma (hint_pragmas($no)) {
- $decls .= "no $pragma;\n";
+ $decls .= $self->keyword("no") . " $pragma;\n";
}
return $decls;
}
@@ -1727,7 +2078,7 @@ my %ignored_hints = (
my %rev_feature;
sub declare_hinthash {
- my ($from, $to, $indent, $hints) = @_;
+ my ($self, $from, $to, $indent, $hints) = @_;
my $doing_features =
($hints & $feature::hint_mask) == $feature::hint_mask;
my @decls;
@@ -1740,10 +2091,10 @@ sub declare_hinthash {
if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) {
push(@features, $key), next if $is_feature;
push @decls,
- qq(\$^H{) . single_delim("q", "'", $key) . qq(} = )
+ qq(\$^H{) . single_delim("q", "'", $key, $self) . qq(} = )
. (
defined $to->{$key}
- ? single_delim("q", "'", $to->{$key})
+ ? single_delim("q", "'", $to->{$key}, $self)
: 'undef'
)
. qq(;);
@@ -1763,17 +2114,17 @@ sub declare_hinthash {
if (!%rev_feature) { %rev_feature = reverse %feature::feature }
}
if (@features) {
- push @ret, "use feature "
+ push @ret, $self->keyword("use") . " feature "
. join(", ", map "'$rev_feature{$_}'", @features) . ";\n";
}
if (@unfeatures) {
- push @ret, "no feature "
+ push @ret, $self->keyword("no") . " feature "
. join(", ", map "'$rev_feature{$_}'", @unfeatures)
. ";\n";
}
@decls and
push @ret,
- join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n";
+ join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n\cK";
return @ret;
}
@@ -1822,20 +2173,36 @@ my %strong_proto_keywords = map { $_ => 1 } qw(
undef
);
-sub keyword {
- my $self = shift;
- my $name = shift;
- return $name if $name =~ /^CORE::/; # just in case
- if (exists $feature_keywords{$name}) {
+sub feature_enabled {
+ my($self,$name) = @_;
my $hh;
my $hints = $self->{hints} & $feature::hint_mask;
if ($hints && $hints != $feature::hint_mask) {
$hh = _features_from_bundle($hints);
}
elsif ($hints) { $hh = $self->{'hinthash'} }
- return "CORE::$name"
- if !$hh
- || !$hh->{"feature_$feature_keywords{$name}"}
+ return $hh && $hh->{"feature_$feature_keywords{$name}"}
+}
+
+sub keyword {
+ my $self = shift;
+ my $name = shift;
+ return $name if $name =~ /^CORE::/; # just in case
+ if (exists $feature_keywords{$name}) {
+ return "CORE::$name" if not $self->feature_enabled($name);
+ }
+ # This sub may be called for a program that has no nextstate ops. In
+ # that case we may have a lexical sub named no/use/sub in scope but
+ # but $self->lex_in_scope will return false because it depends on the
+ # current nextstate op. So we need this alternate method if there is
+ # no current cop.
+ if (!$self->{'curcop'}) {
+ $self->populate_curcvlex() if !defined $self->{'curcvlex'};
+ return "CORE::$name" if exists $self->{'curcvlex'}{"m&$name"}
+ || exists $self->{'curcvlex'}{"o&$name"};
+ } elsif ($self->lex_in_scope("&$name")
+ || $self->lex_in_scope("&$name", 1)) {
+ return "CORE::$name";
}
if ($strong_proto_keywords{$name}
|| ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
@@ -1857,16 +2224,7 @@ sub baseop {
return $self->keyword($name);
}
-sub pp_stub {
- my $self = shift;
- my($op, $cx, $name) = @_;
- if ($cx >= 1) {
- return "()";
- }
- else {
- return "();";
- }
-}
+sub pp_stub { "()" }
sub pp_wantarray { baseop(@_, "wantarray") }
sub pp_fork { baseop(@_, "fork") }
sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
@@ -1918,6 +2276,8 @@ sub pp_i_predec { pfixop(@_, "--", 23) }
sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
+*pp_ncomplement = *pp_complement;
+sub pp_scomplement { maybe_targmy(@_, \&pfixop, "~.", 21) }
sub pp_negate { maybe_targmy(@_, \&real_negate) }
sub real_negate {
@@ -1955,13 +2315,17 @@ sub unop {
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
);
@@ -2032,7 +2396,19 @@ sub pp_tell { unop(@_, "tell") }
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") }
@@ -2054,7 +2430,7 @@ sub pp_dofile {
sub pp_entereval {
unop(
@_,
- $_[1]->private & OPpEVAL_BYTES ? $_[0]->keyword('evalbytes') : "eval"
+ $_[1]->private & OPpEVAL_BYTES ? 'evalbytes' : "eval"
)
}
@@ -2104,17 +2480,18 @@ sub pp_exists {
my $self = shift;
my($op, $cx) = @_;
my $arg;
+ my $name = $self->keyword("exists");
if ($op->private & OPpEXISTS_SUB) {
# Checking for the existence of a subroutine
- return $self->maybe_parens_func("exists",
+ return $self->maybe_parens_func($name,
$self->pp_rv2cv($op->first, 16), $cx, 16);
}
if ($op->flags & OPf_SPECIAL) {
# Array element, not hash element
- return $self->maybe_parens_func("exists",
+ return $self->maybe_parens_func($name,
$self->pp_aelem($op->first, 16), $cx, 16);
}
- return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
+ return $self->maybe_parens_func($name, $self->pp_helem($op->first, 16),
$cx, 16);
}
@@ -2122,24 +2499,25 @@ sub pp_delete {
my $self = shift;
my($op, $cx) = @_;
my $arg;
+ my $name = $self->keyword("delete");
if ($op->private & OPpSLICE) {
if ($op->flags & OPf_SPECIAL) {
# Deleting from an array, not a hash
- return $self->maybe_parens_func("delete",
+ return $self->maybe_parens_func($name,
$self->pp_aslice($op->first, 16),
$cx, 16);
}
- return $self->maybe_parens_func("delete",
+ return $self->maybe_parens_func($name,
$self->pp_hslice($op->first, 16),
$cx, 16);
} else {
if ($op->flags & OPf_SPECIAL) {
# Deleting from an array, not a hash
- return $self->maybe_parens_func("delete",
+ return $self->maybe_parens_func($name,
$self->pp_aelem($op->first, 16),
$cx, 16);
}
- return $self->maybe_parens_func("delete",
+ return $self->maybe_parens_func($name,
$self->pp_helem($op->first, 16),
$cx, 16);
}
@@ -2149,23 +2527,30 @@ sub pp_require {
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 {
@@ -2222,19 +2607,17 @@ sub pp_refgen {
my($op, $cx) = @_;
my $kid = $op->first;
if ($kid->name eq "null") {
- $kid = $kid->first;
- if (!null($kid->sibling) and
- $kid->sibling->name eq "anoncode") {
- return $self->e_anoncode({ code => $self->padval($kid->sibling->targ) });
+ 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") {
+ return $self->e_anoncode({ code => $self->padval($anoncode->targ) });
} elsif ($kid->name eq "pushmark") {
my $sib_name = $kid->sibling->name;
- if ($sib_name =~ /^(pad|rv2)[ah]v$/
- and not $kid->sibling->flags & OPf_REF)
- {
- # The @a in \(@a) isn't in ref context, but only when the
- # parens are there.
- return "\\(" . $self->pp_list($op->first) . ")";
- } elsif ($sib_name eq 'entersub') {
+ if ($sib_name eq 'entersub') {
my $text = $self->deparse($kid->sibling, 1);
# Always show parens for \(&func()), but only with -p otherwise
$text = "($text)" if $self->{'parens'}
@@ -2243,13 +2626,14 @@ sub pp_refgen {
}
}
}
+ local $self->{'in_refgen'} = 1;
$self->pfixop($op, $cx, "\\", 20);
}
sub e_anoncode {
my ($self, $info) = @_;
my $text = $self->deparse_sub($info->{code});
- return "sub " . $text;
+ return $self->keyword("sub") . " $text";
}
sub pp_srefgen { pp_refgen(@_) }
@@ -2258,8 +2642,11 @@ sub pp_readline {
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)) {
+ my $kid_deparsed = $self->deparse($kid, 1);
+ return '<<>>' if $op->flags & OPf_SPECIAL and $kid_deparsed eq 'ARGV';
+ return "<$kid_deparsed>";
+ }
return $self->unop($op, $cx, "readline");
}
@@ -2300,6 +2687,8 @@ sub loopex {
# 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);
@@ -2398,8 +2787,10 @@ BEGIN {
'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,
);
@@ -2426,13 +2817,14 @@ BEGIN {
'multiply=' => 7, 'i_multiply=' => 7,
'divide=' => 7, 'i_divide=' => 7,
'modulo=' => 7, 'i_modulo=' => 7,
- 'repeat=' => 7,
+ 'repeat=' => 7, 'refassign' => 7, 'refassign=' => 7,
'add=' => 7, 'i_add=' => 7,
'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,
);
@@ -2463,9 +2855,17 @@ sub binop {
if ($flags & SWAP_CHILDREN) {
($left, $right) = ($right, $left);
}
+ my $leftop = $left;
$left = $self->deparse_binop_left($op, $left, $prec);
$left = "($left)" if $flags & LIST_CONTEXT
- && $left !~ /^(my|our|local|)[\@\(]/;
+ and $left !~ /^(my|our|local|)[\@\(]/
+ || do {
+ # Parenthesize if the left argument is a
+ # lone repeat op.
+ my $left = $leftop->first->sibling;
+ $left->name eq 'repeat'
+ && null($left->sibling);
+ };
$right = $self->deparse_binop_right($op, $right, $prec);
return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
}
@@ -2487,6 +2887,12 @@ sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
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) }
@@ -2501,7 +2907,7 @@ sub pp_i_lt { binop(@_, "<", 15) }
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) }
@@ -2509,7 +2915,7 @@ sub pp_slt { binop(@_, "lt", 15) }
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) }
@@ -2544,8 +2950,10 @@ sub real_concat {
return $self->maybe_parens("$left .$eq $right", $cx, $prec);
}
+sub pp_repeat { maybe_targmy(@_, \&repeat) }
+
# 'x' is weird when the left arg is a list
-sub pp_repeat {
+sub repeat {
my $self = shift;
my($op, $cx) = @_;
my $left = $op->first;
@@ -2557,6 +2965,7 @@ sub pp_repeat {
$prec = 7;
}
if (null($right)) { # list repeat; count is inside left-side ex-list
+ # in 5.21.5 and earlier
my $kid = $left->first->sibling; # skip pushmark
my @exprs;
for (; !null($kid->sibling); $kid = $kid->sibling) {
@@ -2565,7 +2974,11 @@ sub pp_repeat {
$right = $kid;
$left = "(" . join(", ", @exprs). ")";
} else {
- $left = $self->deparse_binop_left($op, $left, $prec);
+ my $dolist = $op->private & OPpREPEAT_DOLIST;
+ $left = $self->deparse_binop_left($op, $left, $dolist ? 1 : $prec);
+ if ($dolist) {
+ $left = "($left)";
+ }
}
$right = $self->deparse_binop_right($op, $right, $prec);
return $self->maybe_parens("$left x$eq $right", $cx, $prec);
@@ -2596,6 +3009,7 @@ sub logop {
my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
my $left = $op->first;
my $right = $op->first->sibling;
+ $blockname &&= $self->keyword($blockname);
if ($cx < 1 and is_scope($right) and $blockname
and $self->{'expand'} < 7)
{ # if ($a) {$b}
@@ -2701,14 +3115,6 @@ sub listop {
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) . ")";
@@ -2731,7 +3137,7 @@ sub pp_substr {
}
maybe_local(@_, listop(@_, "substr"))
}
-sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
+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") }
@@ -2785,8 +3191,8 @@ sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
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") }
@@ -2919,7 +3325,9 @@ sub indirop {
# 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);
}
}
@@ -2947,7 +3355,8 @@ sub mapop {
$expr = $self->deparse($kid, 6);
push @exprs, $expr if defined $expr;
}
- return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
+ return $self->maybe_parens_func($self->keyword($name),
+ $code . join(", ", @exprs), $cx, 5);
}
sub pp_mapwhile { mapop(@_, "map") }
@@ -2955,6 +3364,18 @@ sub pp_grepwhile { mapop(@_, "grep") }
sub pp_mapstart { baseop(@_, "map") }
sub pp_grepstart { baseop(@_, "grep") }
+my %uses_intro;
+BEGIN {
+ @uses_intro{
+ eval { require B::Op_private }
+ ? @{$B::Op_private::ops_using{OPpLVAL_INTRO}}
+ : qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice
+ hslice delete padsv padav padhv enteriter entersub padrange
+ pushmark cond_expr refassign list)
+ } = ();
+ delete @uses_intro{qw( lvref lvrefslice lvavref entersub )};
+}
+
sub pp_list {
my $self = shift;
my($op, $cx) = @_;
@@ -2963,48 +3384,61 @@ sub pp_list {
return '' if class($kid) eq 'NULL';
my $lop;
my $local = "either"; # could be local(...), my(...), state(...) or our(...)
+ my $type;
for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
- # This assumes that no other private flags equal 128, and that
- # OPs that store things other than flags in their op_private,
- # like OP_AELEMFAST, won't be immediate children of a list.
- #
- # OP_ENTERSUB and OP_SPLIT can break this logic, so check for them.
- # I suspect that open and exit can too.
- # XXX This really needs to be rewritten to accept only those ops
- # known to take the OPpLVAL_INTRO flag.
-
- if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
- or $lop->name eq "undef")
- or $lop->name =~ /^(?:entersub|exit|open|split)\z/)
- {
- $local = ""; # or not
- last;
- }
- if ($lop->name =~ /^pad[ash]v$/) {
- if ($lop->private & OPpPAD_STATE) { # state()
- ($local = "", last) if $local =~ /^(?:local|our|my)$/;
+ my $lopname = $lop->name;
+ my $loppriv = $lop->private;
+ my $newtype;
+ if ($lopname =~ /^pad[ash]v$/ && $loppriv & OPpLVAL_INTRO) {
+ if ($loppriv & OPpPAD_STATE) { # state()
+ ($local = "", last) if $local !~ /^(?:either|state)$/;
$local = "state";
} else { # my()
- ($local = "", last) if $local =~ /^(?:local|our|state)$/;
+ ($local = "", last) if $local !~ /^(?:either|my)$/;
$local = "my";
}
- } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
- && $lop->private & OPpOUR_INTRO
- or $lop->name eq "null" && $lop->first->name eq "gvsv"
+ my $padname = $self->padname_sv($lop->targ);
+ if ($padname->FLAGS & SVpad_TYPED) {
+ $newtype = $padname->SvSTASH->NAME;
+ }
+ } elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/
+ && $loppriv & OPpOUR_INTRO
+ or $lopname eq "null" && class($lop) eq 'UNOP'
+ && $lop->first->name eq "gvsv"
&& $lop->first->private & OPpOUR_INTRO) { # our()
- ($local = "", last) if $local =~ /^(?:my|local|state)$/;
- $local = "our";
- } elsif ($lop->name ne "undef"
- # specifically avoid the "reverse sort" optimisation,
- # where "reverse" is nullified
- && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
+ my $newlocal = "local " x !!($loppriv & OPpLVAL_INTRO) . "our";
+ ($local = "", last)
+ if $local ne 'either' && $local ne $newlocal;
+ $local = $newlocal;
+ my $funny = !$1 || $1 eq 's' ? '$' : $1 eq 'a' ? '@' : '%';
+ if (my $t = $self->find_our_type(
+ $funny . $self->gv_or_padgv($lop->first)->NAME
+ )) {
+ $newtype = $t;
+ }
+ } elsif ($lopname ne 'undef'
+ and !($loppriv & OPpLVAL_INTRO)
+ || !exists $uses_intro{$lopname eq 'null'
+ ? substr B::ppname($lop->targ), 3
+ : $lopname})
+ {
+ $local = ""; # or not
+ last;
+ } elsif ($lopname ne "undef")
{
# local()
- ($local = "", last) if $local =~ /^(?:my|our|state)$/;
+ ($local = "", last) if $local !~ /^(?:either|local)$/;
$local = "local";
}
+ if (defined $type && defined $newtype && $newtype ne $type) {
+ $local = '';
+ last;
+ }
+ $type = $newtype;
}
$local = "" if $local eq "either"; # no point if it's all undefs
+ $local &&= join ' ', map $self->keyword($_), split / /, $local;
+ $local .= " $type " if $local && length $type;
return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
for (; !null($kid); $kid = $kid->sibling) {
if ($local) {
@@ -3053,8 +3487,9 @@ sub pp_cond_expr {
$cond = $self->deparse($cond, 1);
$true = $self->deparse($true, 0);
- my $head = "if ($cond) {\n\t$true\n\b}";
+ my $head = $self->keyword("if") . " ($cond) {\n\t$true\n\b}";
my @elsifs;
+ my $elsif;
while (!null($false) and is_ifelse_cont($false)) {
my $newop = $false->first;
my $newcond = $newop->first;
@@ -3068,10 +3503,11 @@ sub pp_cond_expr {
}
$newcond = $self->deparse($newcond, 1);
$newtrue = $self->deparse($newtrue, 0);
- push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
+ $elsif ||= $self->keyword("elsif");
+ push @elsifs, "$elsif ($newcond) {\n\t$newtrue\n\b}";
}
if (!null($false)) {
- $false = $cuddle . "else {\n\t" .
+ $false = $cuddle . $self->keyword("else") . " {\n\t" .
$self->deparse($false, 0) . "\n\b}\cK";
} else {
$false = "\cK";
@@ -3084,7 +3520,9 @@ sub pp_once {
my $cond = $op->first;
my $true = $cond->sibling;
- return $self->deparse($true, $cx);
+ my $ret = $self->deparse($true, $cx);
+ $ret =~ s/^(\(?)\$/$1 . $self->keyword("state") . ' $'/e;
+ $ret;
}
sub loop_common {
@@ -3098,6 +3536,7 @@ sub loop_common {
my $bare = 0;
my $body;
my $cond = undef;
+ my $name;
if ($kid->name eq "lineseq") { # bare or infinite loop
if ($kid->last->name eq "unstack") { # infinite
$head = "while (1) "; # Can't use for(;;) if there's a continue
@@ -3121,12 +3560,7 @@ sub loop_common {
$ary = $self->deparse($ary, 1);
}
if (null $var) {
- if (($enter->flags & OPf_SPECIAL) && ($] < 5.009)) {
- # thread special var, under 5005threads
- $var = $self->pp_threadsv($enter, 1);
- } else { # regular my() variable
- $var = $self->pp_padsv($enter, 1, 1);
- }
+ $var = $self->pp_padsv($enter, 1, 1);
} elsif ($var->name eq "rv2gv") {
$var = $self->pp_rv2sv($var, 1);
if ($enter->private & OPpOUR_INTRO) {
@@ -3136,19 +3570,21 @@ sub loop_common {
}
} elsif ($var->name eq "gv") {
$var = "\$" . $self->deparse($var, 1);
+ } else {
+ $var = $self->deparse($var, 1);
}
$body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
if (!is_state $body->first and $body->first->name !~ /^(?:stub|leave|scope)$/) {
confess unless $var eq '$_';
$body = $body->first;
- return $self->deparse($body, 2) . " foreach ($ary)";
+ return $self->deparse($body, 2) . " "
+ . $self->keyword("foreach") . " ($ary)";
}
$head = "foreach $var ($ary) ";
} elsif ($kid->name eq "null") { # while/until
$kid = $kid->first;
- my $name = {"and" => "while", "or" => "until"}->{$kid->name};
- $cond = $self->deparse($kid->first, 1);
- $head = "$name ($cond) ";
+ $name = {"and" => "while", "or" => "until"}->{$kid->name};
+ $cond = $kid->first;
$body = $kid->first->sibling;
} elsif ($kid->name eq "stub") { # bare and empty
return "{;}"; # {} could be a hashref
@@ -3160,6 +3596,8 @@ sub loop_common {
# block (or the last in a bare loop).
my $cont_start = $enter->nextop;
my $cont;
+ my $precond;
+ my $postcond;
if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
if ($bare) {
$cont = $body->last;
@@ -3177,7 +3615,8 @@ sub loop_common {
}
$body = $self->lineseq(undef, 0, @states);
if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
- $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
+ $precond = "for ($init; ";
+ $postcond = "; " . $self->deparse($cont, 1) .") ";
$cont = "\cK";
} else {
$cont = $cuddle . "continue {\n\t" .
@@ -3186,11 +3625,23 @@ sub loop_common {
} else {
return "" if !defined $body;
if (length $init) {
- $head = "for ($init; $cond;) ";
+ $precond = "for ($init; ";
+ $postcond = ";) ";
}
$cont = "\cK";
$body = $self->deparse($body, 0);
}
+ if ($precond) { # for(;;)
+ $cond &&= $name eq 'until'
+ ? listop($self, undef, 1, "not", $cond->first)
+ : $self->deparse($cond, 1);
+ $head = "$precond$cond$postcond";
+ }
+ if ($name && !$head) {
+ ref $cond and $cond = $self->deparse($cond, 1);
+ $head = "$name ($cond) ";
+ }
+ $head =~ s/^(for(?:each)?|while|until)/$self->keyword($1)/e;
$body =~ s/;?$/;\n/;
return $head . "{\n\t" . $body . "\b}" . $cont;
@@ -3220,11 +3671,12 @@ sub _op_is_or_was {
}
sub pp_null {
- my $self = shift;
- my($op, $cx) = @_;
+ my($self, $op, $cx) = @_;
if (class($op) eq "OP") {
# old value is lost
return $self->{'ex_const'} if $op->targ == OP_CONST;
+ } elsif (class ($op) eq "COP") {
+ return &pp_nextstate;
} elsif ($op->first->name eq 'pushmark'
or $op->first->name eq 'null'
&& $op->first->targ == OP_PUSHMARK
@@ -3253,13 +3705,14 @@ sub pp_null {
. $self->deparse($op->first->sibling, 7),
$cx, 7);
} elsif (!null($op->first->sibling) and
- $op->first->sibling->name eq "trans" and
+ $op->first->sibling->name =~ /^transr?\z/ and
$op->first->sibling->flags & OPf_STACKED) {
return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
. $self->deparse($op->first->sibling, 20),
$cx, 20);
} elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
- return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
+ return ($self->lex_in_scope("&do") ? "CORE::do" : "do")
+ . " {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
} elsif (!null($op->first->sibling) and
$op->first->sibling->name eq "null" and
class($op->first->sibling) eq "UNOP" and
@@ -3288,20 +3741,15 @@ sub padany {
sub pp_padsv {
my $self = shift;
my($op, $cx, $forbid_parens) = @_;
- return $self->maybe_my($op, $cx, $self->padname($op->targ),
+ my $targ = $op->targ;
+ return $self->maybe_my($op, $cx, $self->padname($targ),
+ $self->padname_sv($targ),
$forbid_parens);
}
sub pp_padav { pp_padsv(@_) }
sub pp_padhv { pp_padsv(@_) }
-my @threadsv_names = B::threadsv_names;
-sub pp_threadsv {
- my $self = shift;
- my($op, $cx) = @_;
- return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
-}
-
sub gv_or_padgv {
my $self = shift;
my $op = shift;
@@ -3443,7 +3891,7 @@ sub pp_rv2av {
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;
@@ -3548,6 +3996,145 @@ sub elem {
}
+# 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;
+}
+
+
+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)->[...]
+ $text .= $self->deparse($op->first, 24);
+ }
+
+ 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")) }
@@ -3654,7 +4241,14 @@ sub _method {
}
if ($meth->name eq "method_named") {
- $meth = $self->const_sv($meth)->PV;
+ $meth = $self->meth_sv($meth)->PV;
+ } elsif ($meth->name eq "method_super") {
+ $meth = "SUPER::".$self->meth_sv($meth)->PV;
+ } elsif ($meth->name eq "method_redir") {
+ $meth = $self->meth_rclass_sv($meth)->PV.'::'.$self->meth_sv($meth)->PV;
+ } elsif ($meth->name eq "method_redir_super") {
+ $meth = $self->meth_rclass_sv($meth)->PV.'::SUPER::'.
+ $self->meth_sv($meth)->PV;
} else {
$meth = $meth->first;
if ($meth->name eq "const") {
@@ -3714,7 +4308,7 @@ sub check_proto {
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;
@@ -3781,6 +4375,50 @@ sub check_proto {
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|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) = @_;
@@ -3801,59 +4439,106 @@ sub pp_entersub {
}
my $simple = 0;
my $proto = undef;
+ my $lexical;
if (is_scope($kid)) {
$amper = "&";
$kid = "{" . $self->deparse($kid, 0) . "}";
} elsif ($kid->first->name eq "gv") {
my $gv = $self->gv_or_padgv($kid->first);
- if (class($gv->CV) ne "SPECIAL") {
- $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
+ my $cv;
+ if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL"
+ || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') {
+ $proto = $cv->PV if $cv->FLAGS & SVf_POK;
}
$simple = 1; # only calls of named functions can be prototyped
$kid = $self->deparse($kid, 24);
- if (!$amper) {
+ my $fq;
+ # Fully qualify any sub name that conflicts with a lexical.
+ if ($self->lex_in_scope("&$kid")
+ || $self->lex_in_scope("&$kid", 1))
+ {
+ $fq++;
+ } elsif (!$amper) {
if ($kid eq 'main::') {
$kid = '::';
- } elsif ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
- $kid = single_delim("q", "'", $kid) . '->';
+ }
+ else {
+ if ($kid !~ /::/ && $kid ne 'x') {
+ # Fully qualify any sub name that is also a keyword. While
+ # we could check the import flag, we cannot guarantee that
+ # the code deparsed so far would set that flag, so we qual-
+ # ify the names regardless of importation.
+ if (exists $feature_keywords{$kid}) {
+ $fq++ if $self->feature_enabled($kid);
+ } elsif (do { local $@; local $SIG{__DIE__};
+ eval { () = prototype "CORE::$kid"; 1 } }) {
+ $fq++
+ }
+ }
+ if ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
+ $kid = single_delim("q", "'", $kid, $self) . '->';
+ }
}
}
+ $fq and substr $kid, 0, 0, = $self->{'curstash'}.'::';
} elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
$amper = "&";
$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 &&
@@ -3869,17 +4554,18 @@ sub pp_entersub {
$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 . ")";
@@ -3913,6 +4599,7 @@ BEGIN {
}
# 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) = @_;
@@ -3926,32 +4613,6 @@ sub re_uninterp {
)
( # $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)
)
@@ -3966,64 +4627,29 @@ sub re_uninterp_extended {
}
}
-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;
}
@@ -4074,21 +4700,22 @@ sub balanced_delim {
}
sub single_delim {
- my($q, $default, $str) = @_;
+ my($q, $default, $str, $self) = @_;
return "$default$str$default" if $default and index($str, $default) == -1;
+ my $coreq = $self->keyword($q); # maybe CORE::q
if ($q ne 'qr') {
(my $succeed, $str) = balanced_delim($str);
- return "$q$str" if $succeed;
+ return "$coreq$str" if $succeed;
}
for my $delim ('/', '"', '#') {
- return "$q$delim" . $str . $delim if index($str, $delim) == -1;
+ return "$coreq$delim" . $str . $delim if index($str, $delim) == -1;
}
if ($default) {
$str =~ s/$default/\\$default/g;
return "$default$str$default";
} else {
$str =~ s[/][\\/]g;
- return "$q/$str/";
+ return "$coreq/$str/";
}
}
@@ -4124,7 +4751,8 @@ sub const {
}
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';
@@ -4189,16 +4817,17 @@ sub const {
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;
@@ -4211,11 +4840,11 @@ sub const {
}
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)));
- return single_delim("qr", "", $re);
+ my $re = re_uninterp(escape_re(re_unback($mg->precomp)));
+ return single_delim("qr", "", $re, $self);
}
}
}
@@ -4227,10 +4856,11 @@ sub const {
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);
+ if ($str =~ /[[:^print:]]/a) {
+ return single_delim("qq", '"',
+ uninterp(escape_str unback $str), $self);
} else {
- return single_delim("q", "'", unback $str);
+ return single_delim("q", "'", unback($str), $self);
}
} else {
return "undef";
@@ -4260,6 +4890,24 @@ sub const_sv {
return $sv;
}
+sub meth_sv {
+ my $self = shift;
+ my $op = shift;
+ my $sv = $op->meth_sv;
+ # the constant could be in the pad (under useithreads)
+ $sv = $self->padval($op->targ) unless $$sv;
+ return $sv;
+}
+
+sub meth_rclass_sv {
+ my $self = shift;
+ my $op = shift;
+ my $sv = $op->rclass;
+ # the constant could be in the pad (under useithreads)
+ $sv = $self->padval($sv) unless ref $sv;
+ return $sv;
+}
+
sub pp_const {
my $self = shift;
my($op, $cx) = @_;
@@ -4317,7 +4965,7 @@ sub pp_backtick {
my $child = $op->first->sibling->isa('B::NULL')
? $op->first : $op->first->sibling;
if ($self->pure_string($child)) {
- return single_delim("qx", '`', $self->dq($child, 1));
+ return single_delim("qx", '`', $self->dq($child, 1), $self);
}
unop($self, @_, "readpipe");
}
@@ -4328,11 +4976,28 @@ sub dquote {
my $kid = $op->first->sibling; # skip ex-stringify, pushmark
return $self->deparse($kid, $cx) if $self->{'unquote'};
$self->maybe_targmy($kid, $cx,
- sub {single_delim("qq", '"', $self->dq($_[1]))});
+ sub {single_delim("qq", '"', $self->dq($_[1]),
+ $self)});
}
# OP_STRINGIFY is a listop, but it only ever has one arg
-sub pp_stringify { maybe_targmy(@_, \&dquote) }
+sub pp_stringify {
+ my ($self, $op, $cx) = @_;
+ my $kid = $op->first->sibling;
+ while ($kid->name eq 'null' && !null($kid->first)) {
+ $kid = $kid->first;
+ }
+ if ($kid->name =~ /^(?:const|padsv|rv2sv|av2arylen|gvsv|multideref
+ |aelemfast(?:_lex)?|[ah]elem|join|concat)\z/x) {
+ maybe_targmy(@_, \&dquote);
+ }
+ else {
+ # Actually an optimised join.
+ my $result = listop(@_,"join");
+ $result =~ s/join([( ])/join$1$self->{'ex_const'}, /;
+ $result;
+ }
+}
# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
# note that tr(from)/to/ is OK, but not tr/from/(to)
@@ -4369,7 +5034,11 @@ sub pchr { # ASCII
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';
@@ -4386,7 +5055,7 @@ sub pchr { # ASCII
} 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);
@@ -4566,7 +5235,7 @@ sub tr_decode_utf8 {
sub pp_trans {
my $self = shift;
- my($op, $cx) = @_;
+ my($op, $cx, $morflags) = @_;
my($from, $to);
my $class = class($op);
my $priv_flags = $op->private;
@@ -4583,10 +5252,16 @@ sub pp_trans {
$flags .= "d" if $priv_flags & OPpTRANS_DELETE;
$to = "" if $from eq $to and $flags eq "";
$flags .= "s" if $priv_flags & OPpTRANS_SQUASH;
- return "tr" . double_delim($from, $to) . $flags;
+ $flags .= $morflags if defined $morflags;
+ my $ret = $self->keyword("tr") . double_delim($from, $to) . $flags;
+ if (my $targ = $op->targ) {
+ return $self->maybe_parens($self->padname($targ) . " =~ $ret",
+ $cx, 20);
+ }
+ return $ret;
}
-sub pp_transr { &pp_trans . 'r' }
+sub pp_transr { push @_, 'r'; goto &pp_trans }
sub re_dq_disambiguate {
my ($first, $last) = @_;
@@ -4601,36 +5276,35 @@ sub re_dq_disambiguate {
# 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 "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;
}
}
@@ -4664,43 +5338,80 @@ sub pure_string {
elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
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/
- )) {
- 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,$cv) = @_;
+
+ # localise stuff relating to the current sub
+ $cv and
+ local($self->{'curcv'}) = $cv,
+ local($self->{'curcvlex'}),
+ local(@$self{qw'curstash warnings hints hinthash curcop'})
+ = @$self{qw'curstash warnings hints hinthash curcop'};
+
+ my $re;
+ for ($op = $op->first->sibling; !null($op); $op = $op->sibling) {
+ if ($op->name eq 'null' and $op->flags & OPf_SPECIAL) {
+ my $scope = $op->first;
+ # 0 context (last arg to scopeop) means statement context, so
+ # the contents of the block will not be wrapped in do{...}.
+ my $block = scopeop($scope->first->name eq "enter", $self,
+ $scope, 0);
+ # next op is the source code of the block
+ $op = $op->sibling;
+ $re .= ($self->const_sv($op)->PV =~ m|^(\(\?\??\{)|)[0];
+ my $multiline = $block =~ /\n/;
+ $re .= $multiline ? "\n\t" : ' ';
+ $re .= $block;
+ $re .= $multiline ? "\n\b})" : " })";
+ } else {
+ $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);
}
@@ -4713,17 +5424,24 @@ sub re_flags {
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 .= "o" if $pmflags & PMf_KEEP;
$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) {
# Hardcoding this is fragile, but B does not yet export the
# constants we need.
- $flags .= qw(d l u a aa)[$charset >> 5]
+ $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
@@ -4746,7 +5464,23 @@ sub re_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.
+#
+# For qr/(?{...})/ without interpolation, the CV is under $qr->qr_anoncv
+# and the code list (list of blocks and constants, maybe vars) is under
+# $cv->ROOT->first->code_list:
+# ./perl -Ilib -MB -e 'use O "Concise", B::svref_2object(sub {qr/(?{die})/})->ROOT->first->first->sibling->pmregexp->qr_anoncv->object_2svref'
+#
+# For qr/$a(?{...})/ with interpolation, the code list is more accessible,
+# under $pmop->code_list, but the $cv is something you have to dig for in
+# the regcomp op’s kids:
+# ./perl -Ilib -mO=Concise -e 'qr/$a(?{die})/'
+#
+# For m// and split //, things are much simpler. There is no CV. The code
+# list is under $pmop->code_list.
sub matchop {
my $self = shift;
@@ -4758,23 +5492,47 @@ sub matchop {
$var = $self->deparse($kid, 20);
$kid = $kid->sibling;
}
+ # not $name; $name will be 'm' for both match and split
+ elsif ($op->name eq 'match' and my $targ = $op->targ) {
+ $binop = 1;
+ $var = $self->padname($targ);
+ }
my $quote = 1;
my $pmflags = $op->pmflags;
- my $extended = ($pmflags & PMf_EXTENDED);
my $rhs_bound_to_defsv;
- if (null $kid) {
- my $unbacked = re_unback($op->precomp);
- if ($extended) {
- $re = re_uninterp_extended(escape_extended_re($unbacked));
- } else {
- $re = re_uninterp(escape_str(re_unback($op->precomp)));
- }
+ 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,
+ $op->name eq 'qr'
+ ? $self->padval(
+ $kid->first # ex-list
+ ->first # pushmark
+ ->sibling # entersub
+ ->first # ex-list
+ ->first # pushmark
+ ->sibling # srefgen
+ ->first # ex-list
+ ->first # anoncode
+ ->targ
+ )
+ : undef);
+ } elsif (${$bregexp = $op->pmregexp} && ${$cv = $bregexp->qr_anoncv}) {
+ my $patop = $cv->ROOT # leavesub
+ ->first # qr
+ ->code_list;# list
+ $re = $self->code_list($patop, $cv);
+ } elsif (!$have_kid) {
+ $re = re_uninterp(escape_re(re_unback($op->precomp)));
} elsif ($kid->name ne 'regcomp') {
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;
- if ($matchop->name eq 'regcrest') {
+ if ($matchop->name eq 'regcreset') {
$matchop = $matchop->first;
}
if ($matchop->name =~ /^(?:match|transr?|subst)\z/
@@ -4789,9 +5547,9 @@ sub matchop {
$flags = $matchwords{$flags} if $matchwords{$flags};
if ($pmflags & PMf_ONCE) { # only one kind of delimiter works here
$re =~ s/\?/\\?/g;
- $re = "?$re?";
+ $re = $self->keyword("m") . "?$re?"; # explicit 'm' is required
} elsif ($quote) {
- $re = single_delim($name, $delim, $re);
+ $re = single_delim($name, $delim, $re, $self);
}
$re = $re . $flags if $quote;
if ($binop) {
@@ -4814,6 +5572,9 @@ 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);
@@ -4827,14 +5588,25 @@ sub pp_split {
# 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);
- }
- $ary = $self->stash_variable('@', $self->gv_name($gv), $cx) if $gv;
-
- for (; !null($kid); $kid = $kid->sibling) {
+ } elsif ($kid->targ) {
+ $ary = $self->padname($kid->targ)
+ } elsif ($stacked) {
+ $ary = $self->deparse($op->last, 7);
+ }
+ $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);
}
@@ -4883,6 +5655,10 @@ sub pp_subst {
$var = $self->deparse($kid, 20);
$kid = $kid->sibling;
}
+ elsif (my $targ = $op->targ) {
+ $binop = 1;
+ $var = $self->padname($targ);
+ }
my $flags = "";
my $pmflags = $op->pmflags;
if (null($op->pmreplroot)) {
@@ -4903,29 +5679,25 @@ sub pp_subst {
$repl = $self->dq($repl);
}
}
- my $extended = ($pmflags & PMf_EXTENDED);
- if (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));
- }
+ if (not null my $code_list = $op->code_list) {
+ $re = $self->code_list($code_list);
+ } elsif (null $kid) {
+ $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;
$flags .= $self->re_flags($op);
$flags = join '', sort split //, $flags;
$flags = $substwords{$flags} if $substwords{$flags};
+ my $core_s = $self->keyword("s"); # maybe CORE::s
if ($binop) {
- return $self->maybe_parens("$var =~ s"
+ return $self->maybe_parens("$var =~ $core_s"
. double_delim($re, $repl) . $flags,
$cx, 20);
} else {
- return "s". double_delim($re, $repl) . $flags;
+ return "$core_s". double_delim($re, $repl) . $flags;
}
}
@@ -4937,6 +5709,10 @@ sub is_lexical_subs {
return 1;
}
+# Pretend these two ops do not exist. The perl parser adds them to the
+# beginning of any block containing my-sub declarations, whereas we handle
+# the subs in pad_subs and next_todo.
+*pp_clonecv = *pp_introcv;
sub pp_introcv {
my $self = shift;
my($op, $cx) = @_;
@@ -4945,20 +5721,66 @@ sub pp_introcv {
return '';
}
-sub pp_clonecv {
- my $self = shift;
- my($op, $cx) = @_;
- my $sv = $self->padname_sv($op->targ);
- my $name = substr $sv->PVX, 1; # skip &/$/@/%, like $self->padany
- return "my sub $name";
-}
-
sub pp_padcv {
my $self = shift;
my($op, $cx) = @_;
return $self->padany($op);
}
+my %lvref_funnies = (
+ OPpLVREF_SV, => '$',
+ OPpLVREF_AV, => '@',
+ OPpLVREF_HV, => '%',
+ OPpLVREF_CV, => '&',
+);
+
+sub pp_refassign {
+ my ($self, $op, $cx) = @_;
+ my $left;
+ if ($op->private & OPpLVREF_ELEM) {
+ $left = $op->first->sibling;
+ $left = maybe_local(@_, elem($self, $left, undef,
+ $left->targ == OP_AELEM
+ ? qw([ ] padav)
+ : qw({ } padhv)));
+ } elsif ($op->flags & OPf_STACKED) {
+ $left = maybe_local(@_,
+ $lvref_funnies{$op->private & OPpLVREF_TYPE}
+ . $self->deparse($op->first->sibling));
+ } else {
+ $left = &pp_padsv;
+ }
+ my $right = $self->deparse_binop_right($op, $op->first, 7);
+ return $self->maybe_parens("\\$left = $right", $cx, 7);
+}
+
+sub pp_lvref {
+ my ($self, $op, $cx) = @_;
+ my $code;
+ if ($op->private & OPpLVREF_ELEM) {
+ $code = $op->first->name =~ /av\z/ ? &pp_aelem : &pp_helem;
+ } elsif ($op->flags & OPf_STACKED) {
+ $code = maybe_local(@_,
+ $lvref_funnies{$op->private & OPpLVREF_TYPE}
+ . $self->deparse($op->first));
+ } else {
+ $code = &pp_padsv;
+ }
+ "\\$code";
+}
+
+sub pp_lvrefslice {
+ my ($self, $op, $cx) = @_;
+ '\\' . ($op->last->name =~ /av\z/ ? &pp_aslice : &pp_hslice);
+}
+
+sub pp_lvavref {
+ my ($self, $op, $cx) = @_;
+ '\\(' . ($op->flags & OPf_STACKED
+ ? maybe_local(@_, rv2x(@_, "\@"))
+ : &pp_padsv) . ')'
+}
+
1;
__END__
@@ -5384,7 +6206,8 @@ the main:: package, the code will include a package declaration.
=item *
-The only pragmas to be completely supported are: C<use warnings>,
+In Perl 5.20 and earlier, 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.)
@@ -5405,8 +6228,8 @@ exactly the right place. So if you use a module which affects compilation
(such as by over-riding keywords, overloading constants or whatever)
then the output code might not work as intended.
-This is the most serious outstanding problem, and will require some help
-from the Perl core to fix.
+This is the most serious problem in Perl 5.20 and earlier. Fixing this
+required internal changes in Perl 5.22.
=item *
@@ -5427,7 +6250,7 @@ produced is already ordinary Perl which shouldn't be filtered again.
=item *
-Optimised away statements are rendered as
+Optimized-away statements are rendered as
'???'. This includes statements that
have a compile-time side-effect, such as the obscure
@@ -5446,26 +6269,18 @@ appear in code2ref 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.
-=item *
-
-There are probably many more bugs on non-ASCII platforms (EBCDIC).
+See also L<Data::Dump::Streamer>, which combines B::Deparse and
+L<PadWalker> to serialize closures properly.
=item *
-Lexical C<my> subroutines are not deparsed properly at the moment. They are
-emitted as pure declarations, without their body; and the declaration may
-appear in the wrong place (before any lexicals the body closes over, or
-before the C<use feature> declaration that permits use of this feature).
-
-We expect to resolve this before the lexical-subroutine feature is no longer
-considered experimental.
+There are probably many more bugs on non-ASCII platforms (EBCDIC).
=item *
-Lexical C<state> subroutines are not deparsed at all at the moment.
-
-We expect to resolve this before the lexical-subroutine feature is no longer
-considered experimental.
+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
diff --git a/Master/tlpkg/tlperl/lib/B/Op_private.pm b/Master/tlpkg/tlperl/lib/B/Op_private.pm
new file mode 100644
index 00000000000..20b598eaaa5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/B/Op_private.pm
@@ -0,0 +1,836 @@
+# -*- buffer-read-only: t -*-
+#
+# lib/B/Op_private.pm
+#
+# Copyright (C) 2014 by Larry Wall and others
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is built by regen/opcode.pl from data in
+# regen/op_private and pod embedded in regen/opcode.pl.
+# Any changes made here will be lost!
+
+=head1 NAME
+
+B::Op_private - OP op_private flag definitions
+
+=head1 SYNOPSIS
+
+ use B::Op_private;
+
+ # flag details for bit 7 of OP_AELEM's op_private:
+ my $name = $B::Op_private::bits{aelem}{7}; # OPpLVAL_INTRO
+ my $value = $B::Op_private::defines{$name}; # 128
+ my $label = $B::Op_private::labels{$name}; # LVINTRO
+
+ # the bit field at bits 5..6 of OP_AELEM's op_private:
+ my $bf = $B::Op_private::bits{aelem}{6};
+ my $mask = $bf->{bitmask}; # etc
+
+=head1 DESCRIPTION
+
+This module provides four global hashes:
+
+ %B::Op_private::bits
+ %B::Op_private::defines
+ %B::Op_private::labels
+ %B::Op_private::ops_using
+
+which contain information about the per-op meanings of the bits in the
+op_private field.
+
+=head2 C<%bits>
+
+This is indexed by op name and then bit number (0..7). For single bit flags,
+it returns the name of the define (if any) for that bit:
+
+ $B::Op_private::bits{aelem}{7} eq 'OPpLVAL_INTRO';
+
+For bit fields, it returns a hash ref containing details about the field.
+The same reference will be returned for all bit positions that make
+up the bit field; so for example these both return the same hash ref:
+
+ $bitfield = $B::Op_private::bits{aelem}{5};
+ $bitfield = $B::Op_private::bits{aelem}{6};
+
+The general format of this hash ref is
+
+ {
+ # The bit range and mask; these are always present.
+ bitmin => 5,
+ bitmax => 6,
+ bitmask => 0x60,
+
+ # (The remaining keys are optional)
+
+ # The names of any defines that were requested:
+ mask_def => 'OPpFOO_MASK',
+ baseshift_def => 'OPpFOO_SHIFT',
+ bitcount_def => 'OPpFOO_BITS',
+
+ # If present, Concise etc will display the value with a 'FOO='
+ # prefix. If it equals '-', then Concise will treat the bit
+ # field as raw bits and not try to interpret it.
+ label => 'FOO',
+
+ # If present, specifies the names of some defines and the
+ # display labels that are used to assign meaning to particu-
+ # lar integer values within the bit field; e.g. 3 is dis-
+ # played as 'C'.
+ enum => [ qw(
+ 1 OPpFOO_A A
+ 2 OPpFOO_B B
+ 3 OPpFOO_C C
+ )],
+
+ };
+
+
+=head2 C<%defines>
+
+This gives the value of every C<OPp> define, e.g.
+
+ $B::Op_private::defines{OPpLVAL_INTRO} == 128;
+
+=head2 C<%labels>
+
+This gives the short display label for each define, as used by C<B::Concise>
+and C<perl -Dx>, e.g.
+
+ $B::Op_private::labels{OPpLVAL_INTRO} eq 'LVINTRO';
+
+If the label equals '-', then Concise will treat the bit as a raw bit and
+not try to display it symbolically.
+
+=head2 C<%ops_using>
+
+For each define, this gives a reference to an array of op names that use
+the flag.
+
+ @ops_using_lvintro = @{ $B::Op_private::ops_using{OPp_LVAL_INTRO} };
+
+=cut
+
+package B::Op_private;
+
+our %bits;
+
+
+our $VERSION = "5.022001";
+
+$bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv);
+$bits{$_}{6} = 'OPpENTERSUB_DB' for qw(entersub rv2cv);
+$bits{$_}{2} = 'OPpENTERSUB_HASTARG' for qw(entersub rv2cv);
+$bits{$_}{6} = 'OPpFLIP_LINENUM' for qw(flip flop);
+$bits{$_}{1} = 'OPpFT_ACCESS' for qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite);
+$bits{$_}{4} = 'OPpFT_AFTER_t' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
+$bits{$_}{2} = 'OPpFT_STACKED' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
+$bits{$_}{3} = 'OPpFT_STACKING' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
+$bits{$_}{1} = 'OPpGREP_LEX' for qw(grepstart grepwhile mapstart mapwhile);
+$bits{$_}{1} = 'OPpHINT_STRICT_REFS' for qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv);
+$bits{$_}{5} = 'OPpHUSH_VMSISH' for qw(dbstate nextstate);
+$bits{$_}{2} = 'OPpITER_REVERSED' for qw(enteriter iter);
+$bits{$_}{7} = 'OPpLVALUE' for qw(leave leaveloop);
+$bits{$_}{6} = 'OPpLVAL_DEFER' for qw(aelem helem multideref);
+$bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv);
+$bits{$_}{2} = 'OPpLVREF_ELEM' for qw(lvref refassign);
+$bits{$_}{3} = 'OPpLVREF_ITER' for qw(lvref refassign);
+$bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem aslice av2arylen helem hslice keys kvaslice kvhslice multideref padav padhv pos rkeys rv2av rv2gv rv2hv substr vec);
+$bits{$_}{4} = 'OPpMAYBE_TRUEBOOL' for qw(padhv rv2hv);
+$bits{$_}{7} = 'OPpOFFBYONE' for qw(caller runcv wantarray);
+$bits{$_}{5} = 'OPpOPEN_IN_CRLF' for qw(backtick open);
+$bits{$_}{4} = 'OPpOPEN_IN_RAW' for qw(backtick open);
+$bits{$_}{7} = 'OPpOPEN_OUT_CRLF' for qw(backtick open);
+$bits{$_}{6} = 'OPpOPEN_OUT_RAW' for qw(backtick open);
+$bits{$_}{6} = 'OPpOUR_INTRO' for qw(enteriter gvsv rv2av rv2hv rv2sv split);
+$bits{$_}{6} = 'OPpPAD_STATE' for qw(lvavref lvref padav padhv padsv pushmark refassign);
+$bits{$_}{7} = 'OPpPV_IS_UTF8' for qw(dump goto last next redo);
+$bits{$_}{6} = 'OPpREFCOUNTED' for qw(leave leaveeval leavesub leavesublv leavewrite);
+$bits{$_}{6} = 'OPpRUNTIME' for qw(match pushre qr subst substcont);
+$bits{$_}{2} = 'OPpSLICEWARNING' for qw(aslice hslice padav padhv rv2av rv2hv);
+$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log match mkdir modulo multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push pushre qr rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subst subtract symlink system time trans transr unlink unshift utime wait waitpid);
+$bits{$_}{5} = 'OPpTRANS_COMPLEMENT' for qw(trans transr);
+$bits{$_}{7} = 'OPpTRANS_DELETE' for qw(trans transr);
+$bits{$_}{0} = 'OPpTRANS_FROM_UTF' for qw(trans transr);
+$bits{$_}{6} = 'OPpTRANS_GROWS' for qw(trans transr);
+$bits{$_}{2} = 'OPpTRANS_IDENTICAL' for qw(trans transr);
+$bits{$_}{3} = 'OPpTRANS_SQUASH' for qw(trans transr);
+$bits{$_}{1} = 'OPpTRANS_TO_UTF' for qw(trans transr);
+$bits{$_}{5} = 'OPpTRUEBOOL' for qw(padhv rv2hv);
+
+my @bf = (
+ {
+ label => '-',
+ mask_def => 'OPpARG1_MASK',
+ bitmin => 0,
+ bitmax => 0,
+ bitmask => 1,
+ },
+ {
+ label => '-',
+ mask_def => 'OPpARG2_MASK',
+ bitmin => 0,
+ bitmax => 1,
+ bitmask => 3,
+ },
+ {
+ label => '-',
+ mask_def => 'OPpARG3_MASK',
+ bitmin => 0,
+ bitmax => 2,
+ bitmask => 7,
+ },
+ {
+ label => '-',
+ mask_def => 'OPpARG4_MASK',
+ bitmin => 0,
+ bitmax => 3,
+ bitmask => 15,
+ },
+ {
+ label => '-',
+ mask_def => 'OPpPADRANGE_COUNTMASK',
+ bitcount_def => 'OPpPADRANGE_COUNTSHIFT',
+ bitmin => 0,
+ bitmax => 6,
+ bitmask => 127,
+ },
+ {
+ label => '-',
+ bitmin => 0,
+ bitmax => 7,
+ bitmask => 255,
+ },
+ {
+ mask_def => 'OPpDEREF',
+ bitmin => 4,
+ bitmax => 5,
+ bitmask => 48,
+ enum => [
+ 1, 'OPpDEREF_AV', 'DREFAV',
+ 2, 'OPpDEREF_HV', 'DREFHV',
+ 3, 'OPpDEREF_SV', 'DREFSV',
+ ],
+ },
+ {
+ mask_def => 'OPpLVREF_TYPE',
+ bitmin => 4,
+ bitmax => 5,
+ bitmask => 48,
+ enum => [
+ 0, 'OPpLVREF_SV', 'SV',
+ 1, 'OPpLVREF_AV', 'AV',
+ 2, 'OPpLVREF_HV', 'HV',
+ 3, 'OPpLVREF_CV', 'CV',
+ ],
+ },
+);
+
+@{$bits{aassign}}{6,1,0} = ('OPpASSIGN_COMMON', $bf[1], $bf[1]);
+$bits{abs}{0} = $bf[0];
+@{$bits{accept}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{add}}{1,0} = ($bf[1], $bf[1]);
+$bits{aeach}{0} = $bf[0];
+@{$bits{aelem}}{5,4,1,0} = ($bf[6], $bf[6], $bf[1], $bf[1]);
+@{$bits{aelemfast}}{7,6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]);
+@{$bits{aelemfast_lex}}{7,6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]);
+$bits{akeys}{0} = $bf[0];
+$bits{alarm}{0} = $bf[0];
+$bits{and}{0} = $bf[0];
+$bits{andassign}{0} = $bf[0];
+$bits{anonconst}{0} = $bf[0];
+@{$bits{anonhash}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{anonlist}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{atan2}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{av2arylen}{0} = $bf[0];
+$bits{avalues}{0} = $bf[0];
+$bits{backtick}{0} = $bf[0];
+@{$bits{bind}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{binmode}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{bit_and}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{bit_or}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{bit_xor}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{bless}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{caller}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{chdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{chmod}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{chomp}{0} = $bf[0];
+$bits{chop}{0} = $bf[0];
+@{$bits{chown}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{chr}{0} = $bf[0];
+$bits{chroot}{0} = $bf[0];
+@{$bits{close}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{closedir}{0} = $bf[0];
+$bits{complement}{0} = $bf[0];
+@{$bits{concat}}{1,0} = ($bf[1], $bf[1]);
+$bits{cond_expr}{0} = $bf[0];
+@{$bits{connect}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{const}}{6,4,3,2,1} = ('OPpCONST_BARE', 'OPpCONST_ENTERED', 'OPpCONST_STRICT', 'OPpCONST_SHORTCIRCUIT', 'OPpCONST_NOVER');
+@{$bits{coreargs}}{7,6,1,0} = ('OPpCOREARGS_PUSHMARK', 'OPpCOREARGS_SCALARMOD', 'OPpCOREARGS_DEREF2', 'OPpCOREARGS_DEREF1');
+$bits{cos}{0} = $bf[0];
+@{$bits{crypt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{dbmclose}{0} = $bf[0];
+@{$bits{dbmopen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{defined}{0} = $bf[0];
+@{$bits{delete}}{6,0} = ('OPpSLICE', $bf[0]);
+@{$bits{die}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{divide}}{1,0} = ($bf[1], $bf[1]);
+$bits{dofile}{0} = $bf[0];
+$bits{dor}{0} = $bf[0];
+$bits{dorassign}{0} = $bf[0];
+$bits{dump}{0} = $bf[0];
+$bits{each}{0} = $bf[0];
+@{$bits{entereval}}{5,4,3,2,1,0} = ('OPpEVAL_RE_REPARSING', 'OPpEVAL_COPHH', 'OPpEVAL_BYTES', 'OPpEVAL_UNICODE', 'OPpEVAL_HAS_HH', $bf[0]);
+$bits{entergiven}{0} = $bf[0];
+$bits{enteriter}{3} = 'OPpITER_DEF';
+@{$bits{entersub}}{5,4,0} = ($bf[6], $bf[6], 'OPpENTERSUB_INARGS');
+$bits{entertry}{0} = $bf[0];
+$bits{enterwhen}{0} = $bf[0];
+@{$bits{enterwrite}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{eof}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{eq}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{exec}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{exists}}{6,0} = ('OPpEXISTS_SUB', $bf[0]);
+@{$bits{exit}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{exp}{0} = $bf[0];
+$bits{fc}{0} = $bf[0];
+@{$bits{fcntl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{fileno}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{flip}{0} = $bf[0];
+@{$bits{flock}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{flop}{0} = $bf[0];
+@{$bits{formline}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{ftatime}{0} = $bf[0];
+$bits{ftbinary}{0} = $bf[0];
+$bits{ftblk}{0} = $bf[0];
+$bits{ftchr}{0} = $bf[0];
+$bits{ftctime}{0} = $bf[0];
+$bits{ftdir}{0} = $bf[0];
+$bits{fteexec}{0} = $bf[0];
+$bits{fteowned}{0} = $bf[0];
+$bits{fteread}{0} = $bf[0];
+$bits{ftewrite}{0} = $bf[0];
+$bits{ftfile}{0} = $bf[0];
+$bits{ftis}{0} = $bf[0];
+$bits{ftlink}{0} = $bf[0];
+$bits{ftmtime}{0} = $bf[0];
+$bits{ftpipe}{0} = $bf[0];
+$bits{ftrexec}{0} = $bf[0];
+$bits{ftrowned}{0} = $bf[0];
+$bits{ftrread}{0} = $bf[0];
+$bits{ftrwrite}{0} = $bf[0];
+$bits{ftsgid}{0} = $bf[0];
+$bits{ftsize}{0} = $bf[0];
+$bits{ftsock}{0} = $bf[0];
+$bits{ftsuid}{0} = $bf[0];
+$bits{ftsvtx}{0} = $bf[0];
+$bits{fttext}{0} = $bf[0];
+$bits{fttty}{0} = $bf[0];
+$bits{ftzero}{0} = $bf[0];
+@{$bits{ge}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{gelem}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{getc}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{getpeername}{0} = $bf[0];
+@{$bits{getpgrp}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{getpriority}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{getsockname}{0} = $bf[0];
+$bits{ggrgid}{0} = $bf[0];
+$bits{ggrnam}{0} = $bf[0];
+@{$bits{ghbyaddr}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{ghbyname}{0} = $bf[0];
+@{$bits{glob}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{gmtime}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{gnbyaddr}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{gnbyname}{0} = $bf[0];
+$bits{goto}{0} = $bf[0];
+$bits{gpbyname}{0} = $bf[0];
+@{$bits{gpbynumber}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{gpwnam}{0} = $bf[0];
+$bits{gpwuid}{0} = $bf[0];
+$bits{grepstart}{0} = $bf[0];
+$bits{grepwhile}{0} = $bf[0];
+@{$bits{gsbyname}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{gsbyport}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{gsockopt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{gt}}{1,0} = ($bf[1], $bf[1]);
+$bits{gv}{5} = 'OPpEARLY_CV';
+@{$bits{helem}}{5,4,1,0} = ($bf[6], $bf[6], $bf[1], $bf[1]);
+$bits{hex}{0} = $bf[0];
+@{$bits{i_add}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_divide}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_eq}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_ge}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_gt}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_le}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_lt}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_modulo}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_multiply}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_ncmp}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_ne}}{1,0} = ($bf[1], $bf[1]);
+$bits{i_negate}{0} = $bf[0];
+$bits{i_postdec}{0} = $bf[0];
+$bits{i_postinc}{0} = $bf[0];
+$bits{i_predec}{0} = $bf[0];
+$bits{i_preinc}{0} = $bf[0];
+@{$bits{i_subtract}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{index}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{int}{0} = $bf[0];
+@{$bits{ioctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{join}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{keys}{0} = $bf[0];
+@{$bits{kill}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{last}{0} = $bf[0];
+$bits{lc}{0} = $bf[0];
+$bits{lcfirst}{0} = $bf[0];
+@{$bits{le}}{1,0} = ($bf[1], $bf[1]);
+$bits{leaveeval}{0} = $bf[0];
+$bits{leavegiven}{0} = $bf[0];
+@{$bits{leaveloop}}{1,0} = ($bf[1], $bf[1]);
+$bits{leavesub}{0} = $bf[0];
+$bits{leavesublv}{0} = $bf[0];
+$bits{leavewhen}{0} = $bf[0];
+$bits{leavewrite}{0} = $bf[0];
+@{$bits{left_shift}}{1,0} = ($bf[1], $bf[1]);
+$bits{length}{0} = $bf[0];
+@{$bits{link}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{list}{6} = 'OPpLIST_GUESSED';
+@{$bits{listen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{localtime}{0} = $bf[0];
+$bits{lock}{0} = $bf[0];
+$bits{log}{0} = $bf[0];
+@{$bits{lslice}}{1,0} = ($bf[1], $bf[1]);
+$bits{lstat}{0} = $bf[0];
+@{$bits{lt}}{1,0} = ($bf[1], $bf[1]);
+$bits{lvavref}{0} = $bf[0];
+@{$bits{lvref}}{5,4,0} = ($bf[7], $bf[7], $bf[0]);
+$bits{mapstart}{0} = $bf[0];
+$bits{mapwhile}{0} = $bf[0];
+$bits{method}{0} = $bf[0];
+$bits{method_named}{0} = $bf[0];
+$bits{method_redir}{0} = $bf[0];
+$bits{method_redir_super}{0} = $bf[0];
+$bits{method_super}{0} = $bf[0];
+@{$bits{mkdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{modulo}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{msgctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{msgget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{msgrcv}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{msgsnd}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{multideref}}{5,4,0} = ('OPpMULTIDEREF_DELETE', 'OPpMULTIDEREF_EXISTS', $bf[0]);
+@{$bits{multiply}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{nbit_and}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{nbit_or}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{nbit_xor}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{ncmp}}{1,0} = ($bf[1], $bf[1]);
+$bits{ncomplement}{0} = $bf[0];
+@{$bits{ne}}{1,0} = ($bf[1], $bf[1]);
+$bits{negate}{0} = $bf[0];
+$bits{next}{0} = $bf[0];
+$bits{not}{0} = $bf[0];
+$bits{oct}{0} = $bf[0];
+$bits{once}{0} = $bf[0];
+@{$bits{open}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{open_dir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{or}{0} = $bf[0];
+$bits{orassign}{0} = $bf[0];
+$bits{ord}{0} = $bf[0];
+@{$bits{pack}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{padrange}}{6,5,4,3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{padsv}}{5,4} = ($bf[6], $bf[6]);
+@{$bits{pipe_op}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{pop}{0} = $bf[0];
+$bits{pos}{0} = $bf[0];
+$bits{postdec}{0} = $bf[0];
+$bits{postinc}{0} = $bf[0];
+@{$bits{pow}}{1,0} = ($bf[1], $bf[1]);
+$bits{predec}{0} = $bf[0];
+$bits{preinc}{0} = $bf[0];
+$bits{prototype}{0} = $bf[0];
+@{$bits{push}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{quotemeta}{0} = $bf[0];
+@{$bits{rand}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{range}{0} = $bf[0];
+$bits{reach}{0} = $bf[0];
+@{$bits{read}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{readdir}{0} = $bf[0];
+$bits{readline}{0} = $bf[0];
+$bits{readlink}{0} = $bf[0];
+@{$bits{recv}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{redo}{0} = $bf[0];
+$bits{ref}{0} = $bf[0];
+@{$bits{refassign}}{5,4,1,0} = ($bf[7], $bf[7], $bf[1], $bf[1]);
+$bits{refgen}{0} = $bf[0];
+$bits{regcmaybe}{0} = $bf[0];
+$bits{regcomp}{0} = $bf[0];
+$bits{regcreset}{0} = $bf[0];
+@{$bits{rename}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{repeat}}{6,1,0} = ('OPpREPEAT_DOLIST', $bf[1], $bf[1]);
+$bits{require}{0} = $bf[0];
+@{$bits{reset}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{reverse}}{3,0} = ('OPpREVERSE_INPLACE', $bf[0]);
+$bits{rewinddir}{0} = $bf[0];
+@{$bits{right_shift}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{rindex}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{rkeys}{0} = $bf[0];
+$bits{rmdir}{0} = $bf[0];
+$bits{rv2av}{0} = $bf[0];
+@{$bits{rv2cv}}{7,5,0} = ('OPpENTERSUB_NOPAREN', 'OPpMAY_RETURN_CONSTANT', $bf[0]);
+@{$bits{rv2gv}}{6,5,4,2,0} = ('OPpALLOW_FAKE', $bf[6], $bf[6], 'OPpDONT_INIT_GV', $bf[0]);
+$bits{rv2hv}{0} = $bf[0];
+@{$bits{rv2sv}}{5,4,0} = ($bf[6], $bf[6], $bf[0]);
+$bits{rvalues}{0} = $bf[0];
+@{$bits{sassign}}{7,6,1,0} = ('OPpASSIGN_CV_TO_GV', 'OPpASSIGN_BACKWARDS', $bf[1], $bf[1]);
+@{$bits{sbit_and}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{sbit_or}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{sbit_xor}}{1,0} = ($bf[1], $bf[1]);
+$bits{scalar}{0} = $bf[0];
+$bits{schomp}{0} = $bf[0];
+$bits{schop}{0} = $bf[0];
+@{$bits{scmp}}{1,0} = ($bf[1], $bf[1]);
+$bits{scomplement}{0} = $bf[0];
+@{$bits{seek}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{seekdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{select}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{semctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{semget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{semop}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{send}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{seq}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{setpgrp}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{setpriority}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{sge}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{sgt}}{1,0} = ($bf[1], $bf[1]);
+$bits{shift}{0} = $bf[0];
+@{$bits{shmctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{shmget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{shmread}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{shmwrite}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{shostent}{0} = $bf[0];
+@{$bits{shutdown}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{sin}{0} = $bf[0];
+@{$bits{sle}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{sleep}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{slt}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{smartmatch}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{sne}}{1,0} = ($bf[1], $bf[1]);
+$bits{snetent}{0} = $bf[0];
+@{$bits{socket}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{sockpair}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{sort}}{6,5,4,3,2,1,0} = ('OPpSORT_STABLE', 'OPpSORT_QSORT', 'OPpSORT_DESCEND', 'OPpSORT_INPLACE', 'OPpSORT_REVERSE', 'OPpSORT_INTEGER', 'OPpSORT_NUMERIC');
+@{$bits{splice}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{split}{7} = 'OPpSPLIT_IMPLIM';
+@{$bits{sprintf}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{sprotoent}{0} = $bf[0];
+$bits{sqrt}{0} = $bf[0];
+@{$bits{srand}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{srefgen}{0} = $bf[0];
+@{$bits{sselect}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{sservent}{0} = $bf[0];
+@{$bits{ssockopt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{stat}{0} = $bf[0];
+@{$bits{stringify}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{study}{0} = $bf[0];
+$bits{substcont}{0} = $bf[0];
+@{$bits{substr}}{4,2,1,0} = ('OPpSUBSTR_REPL_FIRST', $bf[2], $bf[2], $bf[2]);
+@{$bits{subtract}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{symlink}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{syscall}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{sysopen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{sysread}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{sysseek}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{system}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{syswrite}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{tell}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{telldir}{0} = $bf[0];
+@{$bits{tie}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{tied}{0} = $bf[0];
+@{$bits{truncate}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{uc}{0} = $bf[0];
+$bits{ucfirst}{0} = $bf[0];
+@{$bits{umask}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{undef}{0} = $bf[0];
+@{$bits{unlink}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{unpack}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{unshift}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{untie}{0} = $bf[0];
+@{$bits{utime}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{values}{0} = $bf[0];
+@{$bits{vec}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{waitpid}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{warn}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{xor}}{1,0} = ($bf[1], $bf[1]);
+
+
+our %defines = (
+ OPpALLOW_FAKE => 64,
+ OPpARG1_MASK => 1,
+ OPpARG2_MASK => 3,
+ OPpARG3_MASK => 7,
+ OPpARG4_MASK => 15,
+ OPpASSIGN_BACKWARDS => 64,
+ OPpASSIGN_COMMON => 64,
+ OPpASSIGN_CV_TO_GV => 128,
+ OPpCONST_BARE => 64,
+ OPpCONST_ENTERED => 16,
+ OPpCONST_NOVER => 2,
+ OPpCONST_SHORTCIRCUIT => 4,
+ OPpCONST_STRICT => 8,
+ OPpCOREARGS_DEREF1 => 1,
+ OPpCOREARGS_DEREF2 => 2,
+ OPpCOREARGS_PUSHMARK => 128,
+ OPpCOREARGS_SCALARMOD => 64,
+ OPpDEREF => 48,
+ OPpDEREF_AV => 16,
+ OPpDEREF_HV => 32,
+ OPpDEREF_SV => 48,
+ OPpDONT_INIT_GV => 4,
+ OPpEARLY_CV => 32,
+ OPpENTERSUB_AMPER => 8,
+ OPpENTERSUB_DB => 64,
+ OPpENTERSUB_HASTARG => 4,
+ OPpENTERSUB_INARGS => 1,
+ OPpENTERSUB_NOPAREN => 128,
+ OPpEVAL_BYTES => 8,
+ OPpEVAL_COPHH => 16,
+ OPpEVAL_HAS_HH => 2,
+ OPpEVAL_RE_REPARSING => 32,
+ OPpEVAL_UNICODE => 4,
+ OPpEXISTS_SUB => 64,
+ OPpFLIP_LINENUM => 64,
+ OPpFT_ACCESS => 2,
+ OPpFT_AFTER_t => 16,
+ OPpFT_STACKED => 4,
+ OPpFT_STACKING => 8,
+ OPpGREP_LEX => 2,
+ OPpHINT_STRICT_REFS => 2,
+ OPpHUSH_VMSISH => 32,
+ OPpITER_DEF => 8,
+ OPpITER_REVERSED => 4,
+ OPpLIST_GUESSED => 64,
+ OPpLVALUE => 128,
+ OPpLVAL_DEFER => 64,
+ OPpLVAL_INTRO => 128,
+ OPpLVREF_AV => 16,
+ OPpLVREF_CV => 48,
+ OPpLVREF_ELEM => 4,
+ OPpLVREF_HV => 32,
+ OPpLVREF_ITER => 8,
+ OPpLVREF_SV => 0,
+ OPpLVREF_TYPE => 48,
+ OPpMAYBE_LVSUB => 8,
+ OPpMAYBE_TRUEBOOL => 16,
+ OPpMAY_RETURN_CONSTANT => 32,
+ OPpMULTIDEREF_DELETE => 32,
+ OPpMULTIDEREF_EXISTS => 16,
+ OPpOFFBYONE => 128,
+ OPpOPEN_IN_CRLF => 32,
+ OPpOPEN_IN_RAW => 16,
+ OPpOPEN_OUT_CRLF => 128,
+ OPpOPEN_OUT_RAW => 64,
+ OPpOUR_INTRO => 64,
+ OPpPADRANGE_COUNTMASK => 127,
+ OPpPADRANGE_COUNTSHIFT => 7,
+ OPpPAD_STATE => 64,
+ OPpPV_IS_UTF8 => 128,
+ OPpREFCOUNTED => 64,
+ OPpREPEAT_DOLIST => 64,
+ OPpREVERSE_INPLACE => 8,
+ OPpRUNTIME => 64,
+ OPpSLICE => 64,
+ OPpSLICEWARNING => 4,
+ OPpSORT_DESCEND => 16,
+ OPpSORT_INPLACE => 8,
+ OPpSORT_INTEGER => 2,
+ OPpSORT_NUMERIC => 1,
+ OPpSORT_QSORT => 32,
+ OPpSORT_REVERSE => 4,
+ OPpSORT_STABLE => 64,
+ OPpSPLIT_IMPLIM => 128,
+ OPpSUBSTR_REPL_FIRST => 16,
+ OPpTARGET_MY => 16,
+ OPpTRANS_COMPLEMENT => 32,
+ OPpTRANS_DELETE => 128,
+ OPpTRANS_FROM_UTF => 1,
+ OPpTRANS_GROWS => 64,
+ OPpTRANS_IDENTICAL => 4,
+ OPpTRANS_SQUASH => 8,
+ OPpTRANS_TO_UTF => 2,
+ OPpTRUEBOOL => 32,
+);
+
+our %labels = (
+ OPpALLOW_FAKE => 'FAKE',
+ OPpASSIGN_BACKWARDS => 'BKWARD',
+ OPpASSIGN_COMMON => 'COMMON',
+ OPpASSIGN_CV_TO_GV => 'CV2GV',
+ OPpCONST_BARE => 'BARE',
+ OPpCONST_ENTERED => 'ENTERED',
+ OPpCONST_NOVER => 'NOVER',
+ OPpCONST_SHORTCIRCUIT => 'SHORT',
+ OPpCONST_STRICT => 'STRICT',
+ OPpCOREARGS_DEREF1 => 'DEREF1',
+ OPpCOREARGS_DEREF2 => 'DEREF2',
+ OPpCOREARGS_PUSHMARK => 'MARK',
+ OPpCOREARGS_SCALARMOD => '$MOD',
+ OPpDEREF_AV => 'DREFAV',
+ OPpDEREF_HV => 'DREFHV',
+ OPpDEREF_SV => 'DREFSV',
+ OPpDONT_INIT_GV => 'NOINIT',
+ OPpEARLY_CV => 'EARLYCV',
+ OPpENTERSUB_AMPER => 'AMPER',
+ OPpENTERSUB_DB => 'DBG',
+ OPpENTERSUB_HASTARG => 'TARG',
+ OPpENTERSUB_INARGS => 'INARGS',
+ OPpENTERSUB_NOPAREN => 'NO()',
+ OPpEVAL_BYTES => 'BYTES',
+ OPpEVAL_COPHH => 'COPHH',
+ OPpEVAL_HAS_HH => 'HAS_HH',
+ OPpEVAL_RE_REPARSING => 'REPARSE',
+ OPpEVAL_UNICODE => 'UNI',
+ OPpEXISTS_SUB => 'SUB',
+ OPpFLIP_LINENUM => 'LINENUM',
+ OPpFT_ACCESS => 'FTACCESS',
+ OPpFT_AFTER_t => 'FTAFTERt',
+ OPpFT_STACKED => 'FTSTACKED',
+ OPpFT_STACKING => 'FTSTACKING',
+ OPpGREP_LEX => 'GREPLEX',
+ OPpHINT_STRICT_REFS => 'STRICT',
+ OPpHUSH_VMSISH => 'HUSH',
+ OPpITER_DEF => 'DEF',
+ OPpITER_REVERSED => 'REVERSED',
+ OPpLIST_GUESSED => 'GUESSED',
+ OPpLVALUE => 'LV',
+ OPpLVAL_DEFER => 'LVDEFER',
+ OPpLVAL_INTRO => 'LVINTRO',
+ OPpLVREF_AV => 'AV',
+ OPpLVREF_CV => 'CV',
+ OPpLVREF_ELEM => 'ELEM',
+ OPpLVREF_HV => 'HV',
+ OPpLVREF_ITER => 'ITER',
+ OPpLVREF_SV => 'SV',
+ OPpMAYBE_LVSUB => 'LVSUB',
+ OPpMAYBE_TRUEBOOL => 'BOOL?',
+ OPpMAY_RETURN_CONSTANT => 'CONST',
+ OPpMULTIDEREF_DELETE => 'DELETE',
+ OPpMULTIDEREF_EXISTS => 'EXISTS',
+ OPpOFFBYONE => '+1',
+ OPpOPEN_IN_CRLF => 'INCR',
+ OPpOPEN_IN_RAW => 'INBIN',
+ OPpOPEN_OUT_CRLF => 'OUTCR',
+ OPpOPEN_OUT_RAW => 'OUTBIN',
+ OPpOUR_INTRO => 'OURINTR',
+ OPpPAD_STATE => 'STATE',
+ OPpPV_IS_UTF8 => 'UTF',
+ OPpREFCOUNTED => 'REFC',
+ OPpREPEAT_DOLIST => 'DOLIST',
+ OPpREVERSE_INPLACE => 'INPLACE',
+ OPpRUNTIME => 'RTIME',
+ OPpSLICE => 'SLICE',
+ OPpSLICEWARNING => 'SLICEWARN',
+ OPpSORT_DESCEND => 'DESC',
+ OPpSORT_INPLACE => 'INPLACE',
+ OPpSORT_INTEGER => 'INT',
+ OPpSORT_NUMERIC => 'NUM',
+ OPpSORT_QSORT => 'QSORT',
+ OPpSORT_REVERSE => 'REV',
+ OPpSORT_STABLE => 'STABLE',
+ OPpSPLIT_IMPLIM => 'IMPLIM',
+ OPpSUBSTR_REPL_FIRST => 'REPL1ST',
+ OPpTARGET_MY => 'TARGMY',
+ OPpTRANS_COMPLEMENT => 'COMPL',
+ OPpTRANS_DELETE => 'DEL',
+ OPpTRANS_FROM_UTF => '<UTF',
+ OPpTRANS_GROWS => 'GROWS',
+ OPpTRANS_IDENTICAL => 'IDENT',
+ OPpTRANS_SQUASH => 'SQUASH',
+ OPpTRANS_TO_UTF => '>UTF',
+ OPpTRUEBOOL => 'BOOL',
+);
+
+
+our %ops_using = (
+ OPpALLOW_FAKE => [qw(rv2gv)],
+ OPpASSIGN_BACKWARDS => [qw(sassign)],
+ OPpASSIGN_COMMON => [qw(aassign)],
+ OPpCONST_BARE => [qw(const)],
+ OPpCOREARGS_DEREF1 => [qw(coreargs)],
+ OPpEARLY_CV => [qw(gv)],
+ OPpENTERSUB_AMPER => [qw(entersub rv2cv)],
+ OPpENTERSUB_INARGS => [qw(entersub)],
+ OPpENTERSUB_NOPAREN => [qw(rv2cv)],
+ OPpEVAL_BYTES => [qw(entereval)],
+ OPpEXISTS_SUB => [qw(exists)],
+ OPpFLIP_LINENUM => [qw(flip flop)],
+ OPpFT_ACCESS => [qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite)],
+ OPpFT_AFTER_t => [qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero)],
+ OPpGREP_LEX => [qw(grepstart grepwhile mapstart mapwhile)],
+ OPpHINT_STRICT_REFS => [qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv)],
+ OPpHUSH_VMSISH => [qw(dbstate nextstate)],
+ OPpITER_DEF => [qw(enteriter)],
+ OPpITER_REVERSED => [qw(enteriter iter)],
+ OPpLIST_GUESSED => [qw(list)],
+ OPpLVALUE => [qw(leave leaveloop)],
+ OPpLVAL_DEFER => [qw(aelem helem multideref)],
+ OPpLVAL_INTRO => [qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv)],
+ OPpLVREF_ELEM => [qw(lvref refassign)],
+ OPpMAYBE_LVSUB => [qw(aassign aelem aslice av2arylen helem hslice keys kvaslice kvhslice multideref padav padhv pos rkeys rv2av rv2gv rv2hv substr vec)],
+ OPpMAYBE_TRUEBOOL => [qw(padhv rv2hv)],
+ OPpMULTIDEREF_DELETE => [qw(multideref)],
+ OPpOFFBYONE => [qw(caller runcv wantarray)],
+ OPpOPEN_IN_CRLF => [qw(backtick open)],
+ OPpOUR_INTRO => [qw(enteriter gvsv rv2av rv2hv rv2sv split)],
+ OPpPAD_STATE => [qw(lvavref lvref padav padhv padsv pushmark refassign)],
+ OPpPV_IS_UTF8 => [qw(dump goto last next redo)],
+ OPpREFCOUNTED => [qw(leave leaveeval leavesub leavesublv leavewrite)],
+ OPpREPEAT_DOLIST => [qw(repeat)],
+ OPpREVERSE_INPLACE => [qw(reverse)],
+ OPpRUNTIME => [qw(match pushre qr subst substcont)],
+ OPpSLICE => [qw(delete)],
+ OPpSLICEWARNING => [qw(aslice hslice padav padhv rv2av rv2hv)],
+ OPpSORT_DESCEND => [qw(sort)],
+ OPpSPLIT_IMPLIM => [qw(split)],
+ OPpSUBSTR_REPL_FIRST => [qw(substr)],
+ OPpTARGET_MY => [qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log match mkdir modulo multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push pushre qr rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subst subtract symlink system time trans transr unlink unshift utime wait waitpid)],
+ OPpTRANS_COMPLEMENT => [qw(trans transr)],
+);
+
+$ops_using{OPpASSIGN_CV_TO_GV} = $ops_using{OPpASSIGN_BACKWARDS};
+$ops_using{OPpCONST_ENTERED} = $ops_using{OPpCONST_BARE};
+$ops_using{OPpCONST_NOVER} = $ops_using{OPpCONST_BARE};
+$ops_using{OPpCONST_SHORTCIRCUIT} = $ops_using{OPpCONST_BARE};
+$ops_using{OPpCONST_STRICT} = $ops_using{OPpCONST_BARE};
+$ops_using{OPpCOREARGS_DEREF2} = $ops_using{OPpCOREARGS_DEREF1};
+$ops_using{OPpCOREARGS_PUSHMARK} = $ops_using{OPpCOREARGS_DEREF1};
+$ops_using{OPpCOREARGS_SCALARMOD} = $ops_using{OPpCOREARGS_DEREF1};
+$ops_using{OPpDONT_INIT_GV} = $ops_using{OPpALLOW_FAKE};
+$ops_using{OPpENTERSUB_DB} = $ops_using{OPpENTERSUB_AMPER};
+$ops_using{OPpENTERSUB_HASTARG} = $ops_using{OPpENTERSUB_AMPER};
+$ops_using{OPpEVAL_COPHH} = $ops_using{OPpEVAL_BYTES};
+$ops_using{OPpEVAL_HAS_HH} = $ops_using{OPpEVAL_BYTES};
+$ops_using{OPpEVAL_RE_REPARSING} = $ops_using{OPpEVAL_BYTES};
+$ops_using{OPpEVAL_UNICODE} = $ops_using{OPpEVAL_BYTES};
+$ops_using{OPpFT_STACKED} = $ops_using{OPpFT_AFTER_t};
+$ops_using{OPpFT_STACKING} = $ops_using{OPpFT_AFTER_t};
+$ops_using{OPpLVREF_ITER} = $ops_using{OPpLVREF_ELEM};
+$ops_using{OPpMAY_RETURN_CONSTANT} = $ops_using{OPpENTERSUB_NOPAREN};
+$ops_using{OPpMULTIDEREF_EXISTS} = $ops_using{OPpMULTIDEREF_DELETE};
+$ops_using{OPpOPEN_IN_RAW} = $ops_using{OPpOPEN_IN_CRLF};
+$ops_using{OPpOPEN_OUT_CRLF} = $ops_using{OPpOPEN_IN_CRLF};
+$ops_using{OPpOPEN_OUT_RAW} = $ops_using{OPpOPEN_IN_CRLF};
+$ops_using{OPpSORT_INPLACE} = $ops_using{OPpSORT_DESCEND};
+$ops_using{OPpSORT_INTEGER} = $ops_using{OPpSORT_DESCEND};
+$ops_using{OPpSORT_NUMERIC} = $ops_using{OPpSORT_DESCEND};
+$ops_using{OPpSORT_QSORT} = $ops_using{OPpSORT_DESCEND};
+$ops_using{OPpSORT_REVERSE} = $ops_using{OPpSORT_DESCEND};
+$ops_using{OPpSORT_STABLE} = $ops_using{OPpSORT_DESCEND};
+$ops_using{OPpTRANS_DELETE} = $ops_using{OPpTRANS_COMPLEMENT};
+$ops_using{OPpTRANS_FROM_UTF} = $ops_using{OPpTRANS_COMPLEMENT};
+$ops_using{OPpTRANS_GROWS} = $ops_using{OPpTRANS_COMPLEMENT};
+$ops_using{OPpTRANS_IDENTICAL} = $ops_using{OPpTRANS_COMPLEMENT};
+$ops_using{OPpTRANS_SQUASH} = $ops_using{OPpTRANS_COMPLEMENT};
+$ops_using{OPpTRANS_TO_UTF} = $ops_using{OPpTRANS_COMPLEMENT};
+$ops_using{OPpTRUEBOOL} = $ops_using{OPpMAYBE_TRUEBOOL};
+
+# ex: set ro:
diff --git a/Master/tlpkg/tlperl/lib/B/Showlex.pm b/Master/tlpkg/tlperl/lib/B/Showlex.pm
index ab684516100..1ad230e7bdf 100644
--- a/Master/tlpkg/tlperl/lib/B/Showlex.pm
+++ b/Master/tlpkg/tlperl/lib/B/Showlex.pm
@@ -1,6 +1,6 @@
package B::Showlex;
-our $VERSION = '1.04';
+our $VERSION = '1.05';
use strict;
use B qw(svref_2object comppadlist class);
@@ -36,7 +36,8 @@ sub shownamearray {
for ($i = 0; $i < $count; $i++) {
my $sv = $els[$i];
if (class($sv) ne "SPECIAL") {
- printf $walkHandle "$i: %s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX;
+ printf $walkHandle "$i: (0x%lx) %s\n",
+ $$sv, $sv->PVX // "undef" || "const";
} else {
printf $walkHandle "$i: %s\n", $sv->terse;
#printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv);
@@ -64,16 +65,27 @@ sub showlex {
my ($newlex, $nosp1); # rendering state vars
+sub padname_terse {
+ my $name = shift;
+ return $name->terse if class($name) eq 'SPECIAL';
+ my $str = $name->PVX;
+ return sprintf "(0x%lx) %s",
+ $$name,
+ length $str ? qq'"$str"' : defined $str ? "const" : 'undef';
+}
+
sub newlex { # drop-in for showlex
my ($objname, $names, $vals) = @_;
my @names = $names->ARRAY;
my @vals = $vals->ARRAY;
my $count = @names;
print $walkHandle "$objname Pad has $count entries\n";
- printf $walkHandle "0: %s\n", $names[0]->terse unless $nosp1;
+ printf $walkHandle "0: %s\n", padname_terse($names[0]) unless $nosp1;
for (my $i = 1; $i < $count; $i++) {
- printf $walkHandle "$i: %s = %s\n", $names[$i]->terse, $vals[$i]->terse
- unless $nosp1 and $names[$i]->terse =~ /SPECIAL/;
+ printf $walkHandle "$i: %s = %s\n", padname_terse($names[$i]),
+ $vals[$i]->terse,
+ unless $nosp1
+ and class($names[$i]) eq 'SPECIAL' || !$names[$i]->LEN;
}
}
@@ -143,10 +155,10 @@ Traditional form:
$ perl -MO=Showlex -e 'my ($i,$j,$k)=(1,"foo")'
Pad of lexical names for comppadlist has 4 entries
- 0: SPECIAL #1 &PL_sv_undef
- 1: PVNV (0x9db0fb0) $i
- 2: PVNV (0x9db0f38) $j
- 3: PVNV (0x9db0f50) $k
+ 0: (0x8caea4) undef
+ 1: (0x9db0fb0) $i
+ 2: (0x9db0f38) $j
+ 3: (0x9db0f50) $k
Pad of lexical values for comppadlist has 5 entries
0: SPECIAL #1 &PL_sv_undef
1: NULL (0x9da4234)
@@ -159,10 +171,10 @@ New-style form:
$ perl -MO=Showlex,-newlex -e 'my ($i,$j,$k)=(1,"foo")'
main Pad has 4 entries
- 0: SPECIAL #1 &PL_sv_undef
- 1: PVNV (0xa0c4fb8) "$i" = NULL (0xa0b8234)
- 2: PVNV (0xa0c4f40) "$j" = NULL (0xa0c4f34)
- 3: PVNV (0xa0c4f58) "$k" = NULL (0xa0c4f4c)
+ 0: (0x8caea4) undef
+ 1: (0xa0c4fb8) "$i" = NULL (0xa0b8234)
+ 2: (0xa0c4f40) "$j" = NULL (0xa0c4f34)
+ 3: (0xa0c4f58) "$k" = NULL (0xa0c4f4c)
-e syntax OK
New form, no specials, outside O framework:
@@ -170,9 +182,9 @@ New form, no specials, outside O framework:
$ perl -MB::Showlex -e \
'my ($i,$j,$k)=(1,"foo"); B::Showlex::compile(-newlex,-nosp)->()'
main Pad has 4 entries
- 1: PVNV (0x998ffb0) "$i" = IV (0x9983234) 1
- 2: PVNV (0x998ff68) "$j" = PV (0x998ff5c) "foo"
- 3: PVNV (0x998ff80) "$k" = NULL (0x998ff74)
+ 1: (0x998ffb0) "$i" = IV (0x9983234) 1
+ 2: (0x998ff68) "$j" = PV (0x998ff5c) "foo"
+ 3: (0x998ff80) "$k" = NULL (0x998ff74)
Note that this example shows the values of the lexicals, whereas the other
examples did not (as they're compile-time only).