diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/B')
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Concise.pm | 249 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Debug.pm | 25 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Deparse.pm | 1717 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Op_private.pm | 836 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Showlex.pm | 44 |
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). |