diff options
Diffstat (limited to 'gnu/usr.bin/perl/lib/B')
| -rw-r--r-- | gnu/usr.bin/perl/lib/B/Deparse-core.t | 23 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/lib/B/Deparse.pm | 1283 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/lib/B/Deparse.t | 629 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/lib/B/Op_private.pm | 338 |
4 files changed, 1784 insertions, 489 deletions
diff --git a/gnu/usr.bin/perl/lib/B/Deparse-core.t b/gnu/usr.bin/perl/lib/B/Deparse-core.t index b42ad0a9022..6ee935f5f71 100644 --- a/gnu/usr.bin/perl/lib/B/Deparse-core.t +++ b/gnu/usr.bin/perl/lib/B/Deparse-core.t @@ -80,21 +80,23 @@ sub testit { $desc .= " (lex sub)" if $lexsub; + my $code; my $code_ref; if ($lexsub) { package lexsubtest; no warnings 'experimental::lexical_subs'; use feature 'lexical_subs'; no strict 'vars'; - $code_ref = - eval "sub { state sub $keyword; ${vars}() = $expr }" - || die "$@ in $expr"; + $code = "sub { state sub $keyword; ${vars}() = $expr }"; + $code_ref = eval $code + or die "$@ in $expr"; } else { package test; use subs (); import subs $keyword; - $code_ref = eval "no strict 'vars'; sub { ${vars}() = $expr }" + $code = "no strict 'vars'; sub { ${vars}() = $expr }"; + $code_ref = eval $code or die "$@ in $expr"; } @@ -102,10 +104,12 @@ sub testit { unless ($got_text =~ / package (?:lexsub)?test; - use strict 'refs', 'subs'; +(?: BEGIN \{\$\{\^WARNING_BITS\} = "[^"]+"\} +)? use strict 'refs', 'subs'; use feature [^\n]+ - \Q$vars\E\(\) = (.*) -}/s) { +(?: (?:CORE::)?state sub \w+; +)? \Q$vars\E\(\) = (.*) +\}/s) { ::fail($desc); ::diag("couldn't extract line from boilerplate\n"); ::diag($got_text); @@ -113,7 +117,8 @@ sub testit { } my $got_expr = $1; - is $got_expr, $expected_expr, $desc; + is $got_expr, $expected_expr, $desc + or ::diag("ORIGINAL CODE:\n$code");; } } @@ -637,7 +642,7 @@ sprintf 123 p sqrt 01 $ srand 01 - stat 01 $ -state 123 p+ # skip with 0 args, as state() => () +state 123 p1+ # skip with 0 args, as state() => () study 01 $+ # sub handled specially substr 234 p diff --git a/gnu/usr.bin/perl/lib/B/Deparse.pm b/gnu/usr.bin/perl/lib/B/Deparse.pm index 9879d678b17..23045a8dd37 100644 --- a/gnu/usr.bin/perl/lib/B/Deparse.pm +++ b/gnu/usr.bin/perl/lib/B/Deparse.pm @@ -12,10 +12,16 @@ 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_PARENS - OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE + OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpKVSLICE + OPpCONST_BARE OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE + OPpSPLIT_ASSIGN OPpSPLIT_LEX + OPpPADHV_ISKEYS OPpRV2HV_ISKEYS + OPpCONCAT_NESTED + OPpMULTICONCAT_APPEND OPpMULTICONCAT_STRINGIFY OPpMULTICONCAT_FAKE + OPpTRUEBOOL OPpINDEX_BOOLNEG SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG SVs_PADTMP SVpad_TYPED CVf_METHOD CVf_LVALUE @@ -46,12 +52,14 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring MDEREF_SHIFT ); -$VERSION = '1.37'; +$VERSION = '1.48'; use strict; -use vars qw/$AUTOLOAD/; +our $AUTOLOAD; use warnings (); require feature; +use Config; + BEGIN { # List version-specific constants here. # Easiest way to keep this code portable between version looks to @@ -69,104 +77,6 @@ BEGIN { } } -# Changes between 0.50 and 0.51: -# - fixed nulled leave with live enter in sort { } -# - fixed reference constants (\"str") -# - handle empty programs gracefully -# - handle infinite loops (for (;;) {}, while (1) {}) -# - differentiate between 'for my $x ...' and 'my $x; for $x ...' -# - various minor cleanups -# - moved globals into an object -# - added '-u', like B::C -# - package declarations using cop_stash -# - subs, formats and code sorted by cop_seq -# Changes between 0.51 and 0.52: -# - added pp_threadsv (special variables under USE_5005THREADS) -# - added documentation -# Changes between 0.52 and 0.53: -# - many changes adding precedence contexts and associativity -# - added '-p' and '-s' output style options -# - various other minor fixes -# Changes between 0.53 and 0.54: -# - added support for new 'for (1..100)' optimization, -# thanks to Gisle Aas -# Changes between 0.54 and 0.55: -# - added support for new qr// construct -# - added support for new pp_regcreset OP -# Changes between 0.55 and 0.56: -# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t -# - fixed $# on non-lexicals broken in last big rewrite -# - added temporary fix for change in opcode of OP_STRINGIFY -# - fixed problem in 0.54's for() patch in 'for (@ary)' -# - fixed precedence in conditional of ?: -# - tweaked list paren elimination in 'my($x) = @_' -# - made continue-block detection trickier wrt. null ops -# - fixed various prototype problems in pp_entersub -# - added support for sub prototypes that never get GVs -# - added unquoting for special filehandle first arg in truncate -# - print doubled rv2gv (a bug) as '*{*GV}' instead of illegal '**GV' -# - added semicolons at the ends of blocks -# - added -l '#line' declaration option -- fixes cmd/subval.t 27,28 -# Changes between 0.56 and 0.561: -# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy) -# - used new B.pm symbolic constants (done by Nick Ing-Simmons) -# Changes between 0.561 and 0.57: -# - stylistic changes to symbolic constant stuff -# - handled scope in s///e replacement code -# - added unquote option for expanding "" into concats, etc. -# - split method and proto parts of pp_entersub into separate functions -# - various minor cleanups -# Changes after 0.57: -# - added parens in \&foo (patch by Albert Dvornik) -# Changes between 0.57 and 0.58: -# - fixed '0' statements that weren't being printed -# - added methods for use from other programs -# (based on patches from James Duncan and Hugo van der Sanden) -# - added -si and -sT to control indenting (also based on a patch from Hugo) -# - added -sv to print something else instead of '???' -# - preliminary version of utf8 tr/// handling -# Changes after 0.58: -# - uses of $op->ppaddr changed to new $op->name (done by Sarathy) -# - added support for Hugo's new OP_SETSTATE (like nextstate) -# Changes between 0.58 and 0.59 -# - added support for Chip's OP_METHOD_NAMED -# - added support for Ilya's OPpTARGET_MY optimization -# - elided arrows before '()' subscripts when possible -# Changes between 0.59 and 0.60 -# - support for method attributes was added -# - some warnings fixed -# - separate recognition of constant subs -# - rewrote continue block handling, now recognizing for loops -# - added more control of expanding control structures -# Changes between 0.60 and 0.61 (mostly by Robin Houston) -# - many bug-fixes -# - support for pragmas and 'use' -# - support for the little-used $[ variable -# - support for __DATA__ sections -# - UTF8 support -# - BEGIN, CHECK, INIT and END blocks -# - scoping of subroutine declarations fixed -# - compile-time output from the input program can be suppressed, so that the -# output is just the deparsed code. (a change to O.pm in fact) -# - our() declarations -# - *all* the known bugs are now listed in the BUGS section -# - comprehensive test mechanism (TEST -deparse) -# Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez) -# - bug-fixes -# - new switch -P -# - support for command-line switches (-l, -0, etc.) -# Changes between 0.63 and 0.64 -# - support for //, CHECK blocks, and assertions -# - improved handling of foreach loops and lexicals -# - option to use Data::Dumper for constants -# - more bug fixes -# - discovered lots more bugs not yet fixed -# -# ... -# -# Changes between 0.72 and 0.73 -# - support new switch constructs - # Todo: # (See also BUGS section at the end of this file) # @@ -361,7 +271,8 @@ BEGIN { BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem - nextstate dbstate rv2av rv2hv helem custom ]) { + kvaslice kvhslice padsv + nextstate dbstate rv2av rv2hv helem custom ]) { eval "sub OP_\U$_ () { " . opnumber($_) . "}" }} @@ -401,13 +312,27 @@ sub _pessimise_walk { # pessimisations end here - if (class($op) eq 'PMOP' - && ref($op->pmreplroot) - && ${$op->pmreplroot} - && $op->pmreplroot->isa( 'B::OP' )) - { - $self-> _pessimise_walk($op->pmreplroot); - } + if (class($op) eq 'PMOP') { + if (ref($op->pmreplroot) + && ${$op->pmreplroot} + && $op->pmreplroot->isa( 'B::OP' )) + { + $self-> _pessimise_walk($op->pmreplroot); + } + + # pessimise any /(?{...})/ code blocks + my ($re, $cv); + my $code_list = $op->code_list; + if ($$code_list) { + $self->_pessimise_walk($code_list); + } + elsif (${$re = $op->pmregexp} && ${$cv = $re->qr_anoncv}) { + $code_list = $cv->ROOT # leavesub + ->first # qr + ->code_list; # list + $self->_pessimise_walk($code_list); + } + } if ($op->flags & OPf_KIDS) { $self-> _pessimise_walk($op->first); @@ -423,6 +348,8 @@ sub _pessimise_walk { sub _pessimise_walk_exe { my ($self, $startop, $visited) = @_; + no warnings 'recursion'; + return unless $$startop; return if $visited->{$$startop}; my ($op, $prevop); @@ -460,6 +387,7 @@ sub _pessimise_walk_exe { sub pessimise { my ($self, $root, $start) = @_; + no warnings 'recursion'; # walk tree in root-to-branch order $self->_pessimise_walk($root); @@ -474,6 +402,9 @@ sub null { return class($op) eq "NULL"; } + +# Add a CV to the list of subs that still need deparsing. + sub todo { my $self = shift; my($cv, $is_form, $name) = @_; @@ -487,58 +418,34 @@ sub todo { } else { $seq = 0; } + my $stash = $cv->STASH; + if (class($stash) eq 'HV') { + $self->{packs}{$stash->NAME}++; + } push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form, $name]; } + +# Pop the next sub from the todo list and deparse it + sub next_todo { my $self = shift; my $ent = shift @{$self->{'subs_todo'}}; - my $cv = $ent->[1]; - if (ref $ent->[3]) { # lexical sub - my @text; + my ($seq, $cv, $is_form, $name) = @$ent; - # At this point, we may not yet have deparsed the hints that allow - # lexical subroutines to be recognized. So adjust the current - # hints and deparse them. - # When lex subs cease being experimental, we should be able to - # remove this code. - { - local $^H = $self->{'hints'}; - local %^H = %{ $self->{'hinthash'} || {} }; - local ${^WARNING_BITS} = $self->{'warnings'}; - feature->import("lexical_subs"); - warnings->unimport("experimental::lexical_subs"); - # Here we depend on the fact that individual features - # will always set the feature bundle to ‘custom’ - # (== $feature::hint_mask). If we had another specific bundle - # enabled previously, normalise it. - if (($self->{'hints'} & $feature::hint_mask) - != $feature::hint_mask) - { - if ($self->{'hinthash'}) { - delete $self->{'hinthash'}{$_} - for grep /^feature_/, keys %{$self->{'hinthash'}}; - } - else { $self->{'hinthash'} = {} } - $self->{'hinthash'} - = _features_from_bundle(@$self{'hints','hinthash'}); - } - push @text, $self->declare_hinthash($self->{'hinthash'}, \%^H, - $self->{indent_size}, $^H); - push @text, $self->declare_warnings($self->{'warnings'}, - ${^WARNING_BITS}) - unless ($self->{'warnings'} // 'u') - eq (${^WARNING_BITS } // 'u'); - $self->{'warnings'} = ${^WARNING_BITS}; - $self->{'hints'} = $^H; - $self->{'hinthash'} = {%^H}; - } + # any 'use strict; package foo' that should come before the sub + # declaration to sync with the first COP of the sub + my $pragmata = ''; + if ($cv and !null($cv->START) and is_state($cv->START)) { + $pragmata = $self->pragmata($cv->START); + } - # Now emit the sub itself. - my $padname = $ent->[3]; - my $flags = $padname->FLAGS; + if (ref $name) { # lexical sub + # emit the sub. + my @text; + my $flags = $name->FLAGS; push @text, - !$cv || $ent->[0] <= $padname->COP_SEQ_RANGE_LOW + !$cv || $seq <= $name->COP_SEQ_RANGE_LOW ? $self->keyword($flags & SVpad_OUR ? "our" : $flags & SVpad_STATE @@ -548,7 +455,7 @@ sub next_todo { # XXX We would do $self->keyword("sub"), but ‘my CORE::sub’ # doesn’t work and ‘my sub’ ignores a &sub in scope. I.e., # we have a core bug here. - push @text, "sub " . substr $padname->PVX, 1; + push @text, "sub " . substr $name->PVX, 1; if ($cv) { # my sub foo { } push @text, " " . $self->deparse_sub($cv); @@ -558,19 +465,41 @@ sub next_todo { # my sub foo; push @text, ";\n"; } - return join "", @text; + return $pragmata . join "", @text; } + my $gv = $cv->GV; - my $name = $ent->[3] // $self->gv_name($gv); - if ($ent->[2]) { - return $self->keyword("format") . " $name =\n" - . $self->deparse_format($ent->[1]). "\n"; + $name //= $self->gv_name($gv); + if ($is_form) { + return $pragmata . $self->keyword("format") . " $name =\n" + . $self->deparse_format($cv). "\n"; } else { my $use_dec; if ($name eq "BEGIN") { $use_dec = $self->begin_is_use($cv); if (defined ($use_dec) and $self->{'expand'} < 5) { - return () if 0 == length($use_dec); + return $pragmata if 0 == length($use_dec); + + # XXX bit of a hack: Test::More's use_ok() method + # builds a fake use statement which deparses as, e.g. + # use Net::Ping (@{$args[0];}); + # As well as being superfluous (the use_ok() is deparsed + # too) and ugly, it fails under use strict and otherwise + # makes use of a lexical var that's not in scope. + # So strip it out. + return $pragmata + if $use_dec =~ + m/ + \A + use \s \S+ \s \(\@\{ + ( + \s*\#line\ \d+\ \".*"\s* + )? + \$args\[0\];\}\); + \n + \Z + /x; + $use_dec =~ s/^(use|no)\b/$self->keyword($1)/e; } } @@ -591,7 +520,7 @@ sub next_todo { } } if ($use_dec) { - return "$p$l$use_dec"; + return "$pragmata$p$l$use_dec"; } if ( $name !~ /::/ and $self->lex_in_scope("&$name") || $self->lex_in_scope("&$name", 1) ) @@ -600,13 +529,14 @@ sub next_todo { } elsif (defined $stash) { $name =~ s/^\Q$stash\E::(?!\z|.*::)//; } - my $ret = "${p}${l}" . $self->keyword("sub") . " $name " + my $ret = "$pragmata${p}${l}" . $self->keyword("sub") . " $name " . $self->deparse_sub($cv); $self->{'subs_declared'}{$name} = 1; return $ret; } } + # Return a "use" declaration for this BEGIN block, if appropriate sub begin_is_use { my ($self, $cv) = @_; @@ -622,6 +552,9 @@ sub begin_is_use { my $req_op = $lineseq->first->sibling; return if $req_op->name ne "require"; + # maybe it's C<require expr> rather than C<require 'foo'> + return if ($req_op->first->name ne 'const'); + my $module; if ($req_op->first->private & OPpCONST_BARE) { # Actually it should always be a bareword @@ -725,7 +658,8 @@ sub stash_subs { if ($seen ||= {})->{ $INC{"overload.pm"} ? overload::StrVal($stash) : $stash }++; - my %stash = svref_2object($stash)->ARRAY; + my $stashobj = svref_2object($stash); + my %stash = $stashobj->ARRAY; while (my ($key, $val) = each %stash) { my $flags = $val->FLAGS; if ($flags & SVf_ROK) { @@ -766,7 +700,20 @@ sub stash_subs { } 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 + + # Ignore imposters (aliases etc) + my $name = $cv->NAME_HEK; + if(defined $name) { + # avoid using $cv->GV here because if the $val GV is + # an alias, CvGV() could upgrade the real stash entry + # from an RV to a GV + next unless $name eq $key; + next unless $$stashobj == ${$cv->STASH}; + } + else { + next if $$val != ${$cv->GV}; + } + $self->todo($cv, 0); } if (class(my $cv = $val->FORM) ne "SPECIAL") { @@ -786,6 +733,14 @@ sub print_protos { my $ar; my @ret; foreach $ar (@{$self->{'protos_todo'}}) { + if (ref $ar->[1]) { + # Only print a constant if it occurs in the same package as a + # dumped sub. This is not perfect, but a heuristic that will + # hopefully work most of the time. Ideally we would use + # CvFILE, but a constant stub has no CvFILE. + my $pack = ($ar->[0] =~ /(.*)::/)[0]; + next if $pack and !$self->{packs}{$pack} + } my $body = defined $ar->[1] ? ref $ar->[1] ? " () {\n " . $self->const($ar->[1]->RV,0) . ";\n}" @@ -827,6 +782,7 @@ sub new { $self->{'ex_const'} = "'???'"; $self->{'expand'} = 0; $self->{'files'} = {}; + $self->{'packs'} = {}; $self->{'indent_size'} = 4; $self->{'linenums'} = 0; $self->{'parens'} = 0; @@ -886,7 +842,6 @@ sub init { ? $self->{'ambient_warnings'} & WARN_MASK : undef; $self->{'hints'} = $self->{'ambient_hints'}; - $self->{'hints'} &= 0xFF if $] < 5.009; $self->{'hinthash'} = $self->{'ambient_hinthash'}; # also a convenient place to clear out subs_declared @@ -1221,22 +1176,132 @@ sub pad_subs { sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo } + +# deparse_argops(): deparse, if possible, a sequence of argcheck + argelem +# ops into a subroutine signature. If successful, return the first op +# following the signature ops plus the signature string; else return the +# empty list. +# +# Normally a bunch of argelem ops will have been generated by the +# signature parsing, but it's possible that ops have been added manually +# or altered. In this case we return "()" and fall back to general +# deparsing of the individual sigelems as 'my $x = $_[N]' etc. +# +# We're only called if the first two ops are nextstate and argcheck. + +sub deparse_argops { + my ($self, $firstop, $cv) = @_; + + my @sig; + my $o = $firstop; + return if $o->label; #first nextstate; + + # OP_ARGCHECK + + $o = $o->sibling; + my ($params, $opt_params, $slurpy) = $o->aux_list($cv); + my $mandatory = $params - $opt_params; + my $seen_slurpy = 0; + my $last_ix = -1; + + # keep looking for valid nextstate + argelem pairs + + while (1) { + # OP_NEXTSTATE + $o = $o->sibling; + last unless $$o; + last unless $o->name =~ /^(next|db)state$/; + last if $o->label; + + # OP_ARGELEM + my $o2 = $o->sibling; + last unless $$o2; + + if ($o2->name eq 'argelem') { + my $ix = $o2->string($cv); + while (++$last_ix < $ix) { + push @sig, $last_ix < $mandatory ? '$' : '$='; + } + my $var = $self->padname($o2->targ); + if ($var =~ /^[@%]/) { + return if $seen_slurpy; + $seen_slurpy = 1; + return if $ix != $params or !$slurpy + or substr($var,0,1) ne $slurpy; + } + else { + return if $ix >= $params; + } + if ($o2->flags & OPf_KIDS) { + my $kid = $o2->first; + return unless $$kid and $kid->name eq 'argdefelem'; + my $def = $self->deparse($kid->first, 7); + $def = "($def)" if $kid->first->flags & OPf_PARENS; + $var .= " = $def"; + } + push @sig, $var; + } + elsif ($o2->name eq 'null' + and ($o2->flags & OPf_KIDS) + and $o2->first->name eq 'argdefelem') + { + # special case - a void context default expression: $ = expr + + my $defop = $o2->first; + my $ix = $defop->targ; + while (++$last_ix < $ix) { + push @sig, $last_ix < $mandatory ? '$' : '$='; + } + return if $last_ix >= $params + or $last_ix < $mandatory; + my $def = $self->deparse($defop->first, 7); + $def = "($def)" if $defop->first->flags & OPf_PARENS; + push @sig, '$ = ' . $def; + } + else { + last; + } + + $o = $o2; + } + + while (++$last_ix < $params) { + push @sig, $last_ix < $mandatory ? '$' : '$='; + } + push @sig, $slurpy if $slurpy and !$seen_slurpy; + + return ($o, join(', ', @sig)); +} + +# Deparse a sub. Returns everything except the 'sub foo', +# e.g. ($$) : method { ...; } +# or : prototype($$) lvalue ($a, $b) { ...; }; + sub deparse_sub { my $self = shift; my $cv = shift; - my $proto = ""; + my @attrs; + my $proto; + my $sig; + Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL"); Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); local $self->{'curcop'} = $self->{'curcop'}; + + my $has_sig = $self->{hinthash}{feature_signatures}; if ($cv->FLAGS & SVf_POK) { - $proto = "(". $cv->PV . ") "; + my $myproto = $cv->PV; + if ($has_sig) { + push @attrs, "prototype($myproto)"; + } + else { + $proto = $myproto; + } } 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; + push @attrs, "lvalue" if $cv->CvFLAGS & CVf_LVALUE; + push @attrs, "method" if $cv->CvFLAGS & CVf_METHOD; + push @attrs, "const" if $cv->CvFLAGS & CVf_ANONCONST; } local($self->{'curcv'}) = $cv; @@ -1251,11 +1316,36 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); $self->pessimise($root, $cv->START); my $lineseq = $root->first; if ($lineseq->name eq "lineseq") { - my @ops; - for(my$o=$lineseq->first; $$o; $o=$o->sibling) { + my $firstop = $lineseq->first; + + if ($has_sig) { + my $o2; + # try to deparse first few ops as a signature if possible + if ( $$firstop + and $firstop->name =~ /^(next|db)state$/ + and (($o2 = $firstop->sibling)) + and $$o2) + { + if ($o2->name eq 'argcheck') { + my ($nexto, $mysig) = $self->deparse_argops($firstop, $cv); + if (defined $nexto) { + $firstop = $nexto; + $sig = $mysig; + } + } + } + } + + my @ops; + for (my $o = $firstop; $$o; $o=$o->sibling) { push @ops, $o; } $body = $self->lineseq(undef, 0, @ops).";"; + if (!$has_sig and $ops[-1]->name =~ /^(next|db)state$/) { + # this handles void context in + # use feature signatures; sub ($=1) {} + $body .= "\n()"; + } my $scope_en = $self->find_scope_en($lineseq); if (defined $scope_en) { my $subs = join"", $self->seq_subs($scope_en); @@ -1265,17 +1355,33 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); else { $body = $self->deparse($root->first, 0); } + + my $l = ''; + if ($self->{'linenums'}) { + # a glob's gp_line is set from the line containing a + # sub's closing '}' if the CV is the first use of the GV. + # So make sure the linenum is set correctly for '}' + my $gv = $cv->GV; + my $line = $gv->LINE; + my $file = $gv->FILE; + $l = "\f#line $line \"$file\"\n"; + } + $body = "{\n\t$body\n$l\b}"; } else { my $sv = $cv->const_sv; if ($$sv) { # uh-oh. inlinable sub... format it differently - return $proto . "{ " . $self->const($sv, 0) . " }\n"; + $body = "{ " . $self->const($sv, 0) . " }\n"; } else { # XSUB? (or just a declaration) - return "$proto;\n"; + $body = ';' } } - return $proto ."{\n\t$body\n\b}" ."\n"; + $proto = defined $proto ? "($proto) " : ""; + $sig = defined $sig ? "($sig) " : ""; + my $attrs = ''; + $attrs = ': ' . join('', map "$_ ", @attrs) if @attrs; + return "$proto$attrs$sig$body\n"; } sub deparse_format { @@ -1469,7 +1575,7 @@ sub maybe_local { if $self->{'avoid_local'}{$$op}; if ($need_parens) { return "$our_local($text)"; - } elsif (want_scalar($op)) { + } elsif (want_scalar($op) || $our_local eq 'our') { return "$our_local $text"; } else { return $self->maybe_parens_func("$our_local", $text, $cx, 16); @@ -1717,7 +1823,7 @@ sub gv_name { sub stash_variable { my ($self, $prefix, $name, $cx) = @_; - return "$prefix$name" if $name =~ /::/; + return $prefix.$self->maybe_qualify($prefix, $name) if $name =~ /::/; unless ($prefix eq '$' || $prefix eq '@' || $prefix eq '&' || #' $prefix eq '%' || $prefix eq '$#') { @@ -1793,11 +1899,16 @@ sub stash_variable_name { sub maybe_qualify { my ($self,$prefix,$name) = @_; my $v = ($prefix eq '$#' ? '@' : $prefix) . $name; - return $name if !$prefix || $name =~ /::/; + if ($prefix eq "") { + $name .= "::" if $name =~ /(?:\ACORE::[^:]*|::)\z/; + return $name; + } + return $name if $name =~ /::/; return $self->{'curstash'}.'::'. $name if $name =~ /^(?!\d)\w/ # alphabetic && $v !~ /^\$[ab]\z/ # not $a or $b + && $v =~ /\A[\$\@\%\&]/ # scalar, array, hash, or sub && !$globalnames{$name} # not a global name && $self->{hints} & $strict_bits{vars} # strict vars && !$self->lex_in_scope($v,1) # no "our" @@ -1887,14 +1998,6 @@ sub find_scope { sub cop_subs { my ($self, $op, $out_seq) = @_; my $seq = $op->cop_seq; - if ($] < 5.021006) { - # If we have nephews, then our sequence number indicates - # the cop_seq of the end of some sort of scope. - if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS - and my $nseq = $self->find_scope_st($op->sibling) ) { - $seq = $nseq; - } - } $seq = $out_seq if defined($out_seq) && $out_seq < $seq; return $self->seq_subs($seq); } @@ -1934,18 +2037,15 @@ sub _features_from_bundle { return $hh; } -# Notice how subs and formats are inserted between statements here; -# also $[ assignments and pragmas. -sub pp_nextstate { +# generate any pragmas, 'package foo' etc needed to synchronise +# with the given cop + +sub pragmata { my $self = shift; - my($op, $cx) = @_; - $self->{'curcop'} = $op; + my($op) = @_; + my @text; - push @text, $self->cop_subs($op); - if (@text) { - # Special marker to swallow up the semicolon - push @text, "\cK"; - } + my $stash = $op->stashpv; if ($stash ne $self->{'curstash'}) { push @text, $self->keyword("package") . " $stash;\n"; @@ -1979,7 +2079,7 @@ sub pp_nextstate { $self->{'warnings'} = $warning_bits; } - my $hints = $] < 5.008009 ? $op->private : $op->hints; + my $hints = $op->hints; my $old_hints = $self->{'hints'}; if ($self->{'hints'} != $hints) { push @text, $self->declare_hints($self->{'hints'}, $hints); @@ -1987,11 +2087,9 @@ sub pp_nextstate { } my $newhh; - if ($] > 5.009) { - $newhh = $op->hints_hash->HASH; - } + $newhh = $op->hints_hash->HASH; - if ($] >= 5.015006) { + { # feature bundle hints my $from = $old_hints & $feature::hint_mask; my $to = $ hints & $feature::hint_mask; @@ -2016,7 +2114,7 @@ sub pp_nextstate { } } - if ($] > 5.009) { + { push @text, $self->declare_hinthash( $self->{'hinthash'}, $newhh, $self->{indent_size}, $self->{hints}, @@ -2024,6 +2122,29 @@ sub pp_nextstate { $self->{'hinthash'} = $newhh; } + return join("", @text); +} + + +# Notice how subs and formats are inserted between statements here; +# also $[ assignments and pragmas. +sub pp_nextstate { + my $self = shift; + my($op, $cx) = @_; + $self->{'curcop'} = $op; + + my @text; + + my @subs = $self->cop_subs($op); + if (@subs) { + # Special marker to swallow up the semicolon + push @subs, "\cK"; + } + push @text, @subs; + + push @text, $self->pragmata($op); + + # This should go after of any branches that add statements, to # increase the chances that it refers to the same line it did in # the original program. @@ -2039,12 +2160,18 @@ sub pp_nextstate { sub declare_warnings { my ($self, $from, $to) = @_; - if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) { - return $self->keyword("use") . " warnings;\n"; - } - elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) { - return $self->keyword("no") . " warnings;\n"; + $from //= ''; + my $all = (warnings::bits("all") & WARN_MASK); + unless ((($from & WARN_MASK) & ~$all) =~ /[^\0]/) { + # no FATAL bits need turning off + if ( ($to & WARN_MASK) eq $all) { + return $self->keyword("use") . " warnings;\n"; + } + elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) { + return $self->keyword("no") . " warnings;\n"; + } } + return "BEGIN {\${^WARNING_BITS} = \"" . join("", map { sprintf("\\x%02x", ord $_) } split "", $to) . "\"}\n\cK"; @@ -2086,7 +2213,7 @@ sub declare_hinthash { my @unfeatures; # bugs? for my $key (sort keys %$to) { next if $ignored_hints{$key}; - my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6; + my $is_feature = $key =~ /^feature_/; next if $is_feature and not $doing_features; if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) { push(@features, $key), next if $is_feature; @@ -2102,7 +2229,7 @@ sub declare_hinthash { } for my $key (sort keys %$from) { next if $ignored_hints{$key}; - my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6; + my $is_feature = $key =~ /^feature_/; next if $is_feature and not $doing_features; if (!exists $to->{$key}) { push(@unfeatures, $key), next if $is_feature; @@ -2500,7 +2627,7 @@ sub pp_delete { my($op, $cx) = @_; my $arg; my $name = $self->keyword("delete"); - if ($op->private & OPpSLICE) { + if ($op->private & (OPpSLICE|OPpKVSLICE)) { if ($op->flags & OPf_SPECIAL) { # Deleting from an array, not a hash return $self->maybe_parens_func($name, @@ -2859,7 +2986,7 @@ sub binop { my $leftop = $left; $left = $self->deparse_binop_left($op, $left, $prec); $left = "($left)" if $flags & LIST_CONTEXT - and $left !~ /^(my|our|local|)[\@\(]/ + and $left !~ /^(my|our|local|state|)\s*[\@%\(]/ || do { # Parenthesize if the left argument is a # lone repeat op. @@ -2923,7 +3050,7 @@ sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) } sub pp_smartmatch { my ($self, $op, $cx) = @_; - if ($op->flags & OPf_SPECIAL) { + if (($op->flags & OPf_SPECIAL) && $self->{expand} < 2) { return $self->deparse($op->last, $cx); } else { @@ -2942,7 +3069,8 @@ sub real_concat { my $right = $op->last; my $eq = ""; my $prec = 18; - if ($op->flags & OPf_STACKED and $op->first->name ne "concat") { + if (($op->flags & OPf_STACKED) and !($op->private & OPpCONCAT_NESTED)) { + # '.=' rather than optimised '.' $eq = "="; $prec = 7; } @@ -3138,9 +3266,35 @@ sub pp_substr { } maybe_local(@_, listop(@_, "substr")) } + +sub pp_index { + # Also handles pp_rindex. + # + # The body of this function includes an unrolled maybe_targmy(), + # since the two parts of that sub's actions need to have have the + # '== -1' bit in between + + my($self, $op, $cx) = @_; + + my $lex = ($op->private & OPpTARGET_MY); + my $bool = ($op->private & OPpTRUEBOOL); + + my $val = $self->listop($op, ($bool ? 14 : $lex ? 7 : $cx), $op->name); + + # (index() == -1) has op_eq and op_const optimised away + if ($bool) { + $val .= ($op->private & OPpINDEX_BOOLNEG) ? " == -1" : " != -1"; + $val = "($val)" if ($op->flags & OPf_PARENS); + } + if ($lex) { + my $var = $self->padname($op->targ); + $val = $self->maybe_parens("$var = $val", $cx, 7); + } + $val; +} + +sub pp_rindex { pp_index(@_); } sub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) } -sub pp_index { maybe_targmy(@_, \&listop, "index") } -sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") } sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") } sub pp_formline { listop(@_, "formline") } # see also deparse_format sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") } @@ -3368,9 +3522,175 @@ BEGIN { delete @uses_intro{qw( lvref lvrefslice lvavref entersub )}; } + +# Look for a my/state attribute declaration in a list or ex-list. +# Returns undef if not found, 'my($x, @a) :Foo(bar)' etc otherwise. +# +# There are three basic tree structs that are expected: +# +# my $x :foo; +# <1> ex-list vK/LVINTRO ->c +# <0> ex-pushmark v ->3 +# <1> entersub[t2] vKRS*/TARG ->b +# .... +# <0> padsv[$x:64,65] vM/LVINTRO ->c +# +# my @a :foo; +# my %h :foo; +# +# <1> ex-list vK ->c +# <0> ex-pushmark v ->3 +# <0> padav[@a:64,65] vM/LVINTRO ->4 +# <1> entersub[t2] vKRS*/TARG ->c +# .... +# +# my ($x,@a,%h) :foo; +# +# <;> nextstate(main 64 -e:1) v:{ ->3 +# <@> list vKP ->w +# <0> pushmark vM/LVINTRO ->4 +# <0> padsv[$x:64,65] vM/LVINTRO ->5 +# <0> padav[@a:64,65] vM/LVINTRO ->6 +# <0> padhv[%h:64,65] vM/LVINTRO ->7 +# <1> entersub[t4] vKRS*/TARG ->f +# .... +# <1> entersub[t5] vKRS*/TARG ->n +# .... +# <1> entersub[t6] vKRS*/TARG ->v +# .... +# where the entersub in all cases looks like +# <1> entersub[t2] vKRS*/TARG ->c +# <0> pushmark s ->5 +# <$> const[PV "attributes"] sM ->6 +# <$> const[PV "main"] sM ->7 +# <1> srefgen sKM/1 ->9 +# <1> ex-list lKRM ->8 +# <0> padsv[@a:64,65] sRM ->8 +# <$> const[PV "foo"] sM ->a +# <.> method_named[PV "import"] ->b + +sub maybe_var_attr { + my ($self, $op, $cx) = @_; + + my $kid = $op->first->sibling; # skip pushmark + return if class($kid) eq 'NULL'; + + my $lop; + my $type; + + # Extract out all the pad ops and entersub ops into + # @padops and @entersubops. Return if anything else seen. + # Also determine what class (if any) all the pad vars belong to + my $class; + my $decl; # 'my' or 'state' + my (@padops, @entersubops); + for ($lop = $kid; !null($lop); $lop = $lop->sibling) { + my $lopname = $lop->name; + my $loppriv = $lop->private; + if ($lopname =~ /^pad[sah]v$/) { + return unless $loppriv & OPpLVAL_INTRO; + + my $padname = $self->padname_sv($lop->targ); + my $thisclass = ($padname->FLAGS & SVpad_TYPED) + ? $padname->SvSTASH->NAME : 'main'; + + # all pad vars must be in the same class + $class //= $thisclass; + return unless $thisclass eq $class; + + # all pad vars must be the same sort of declaration + # (all my, all state, etc) + my $this = ($loppriv & OPpPAD_STATE) ? 'state' : 'my'; + if (defined $decl) { + return unless $this eq $decl; + } + $decl = $this; + + push @padops, $lop; + } + elsif ($lopname eq 'entersub') { + push @entersubops, $lop; + } + else { + return; + } + } + + return unless @padops && @padops == @entersubops; + + # there should be a balance: each padop has a corresponding + # 'attributes'->import() method call, in the same order. + + my @varnames; + my $attr_text; + + for my $i (0..$#padops) { + my $padop = $padops[$i]; + my $esop = $entersubops[$i]; + + push @varnames, $self->padname($padop->targ); + + return unless ($esop->flags & OPf_KIDS); + + my $kid = $esop->first; + return unless $kid->type == OP_PUSHMARK; + + $kid = $kid->sibling; + return unless $$kid && $kid->type == OP_CONST; + return unless $self->const_sv($kid)->PV eq 'attributes'; + + $kid = $kid->sibling; + return unless $$kid && $kid->type == OP_CONST; # __PACKAGE__ + + $kid = $kid->sibling; + return unless $$kid + && $kid->name eq "srefgen" + && ($kid->flags & OPf_KIDS) + && ($kid->first->flags & OPf_KIDS) + && $kid->first->first->name =~ /^pad[sah]v$/ + && $kid->first->first->targ == $padop->targ; + + $kid = $kid->sibling; + my @attr; + while ($$kid) { + last if ($kid->type != OP_CONST); + push @attr, $self->const_sv($kid)->PV; + $kid = $kid->sibling; + } + return unless @attr; + my $thisattr = ":" . join(' ', @attr); + $attr_text //= $thisattr; + # all import calls must have the same list of attributes + return unless $attr_text eq $thisattr; + + return unless $kid->name eq 'method_named'; + return unless $self->meth_sv($kid)->PV eq 'import'; + + $kid = $kid->sibling; + return if $$kid; + } + + my $res = $decl; + $res .= " $class " if $class ne 'main'; + $res .= + (@varnames > 1) + ? "(" . join(', ', @varnames) . ')' + : " $varnames[0]"; + + return "$res $attr_text"; +} + + sub pp_list { my $self = shift; my($op, $cx) = @_; + + { + # might be my ($s,@a,%h) :Foo(bar); + my $my_attr = maybe_var_attr($self, $op, $cx); + return $my_attr if defined $my_attr; + } + my($expr, @exprs); my $kid = $op->first->sibling; # skip pushmark return '' if class($kid) eq 'NULL'; @@ -3448,6 +3768,10 @@ sub pp_list { push @exprs, $expr; } if ($local) { + if (@exprs == 1 && ($local eq 'state' || $local eq 'CORE::state')) { + # 'state @a = ...' is legal, while 'state(@a) = ...' currently isn't + return "$local $exprs[0]"; + } return "$local(" . join(", ", @exprs) . ")"; } else { return $self->maybe_parens( join(", ", @exprs), $cx, 6); @@ -3664,6 +3988,13 @@ sub _op_is_or_was { sub pp_null { my($self, $op, $cx) = @_; + + # might be 'my $s :Foo(bar);' + if ($op->targ == OP_LIST) { + my $my_attr = maybe_var_attr($self, $op, $cx); + return $my_attr if defined $my_attr; + } + if (class($op) eq "OP") { # old value is lost return $self->{'ex_const'} if $op->targ == OP_CONST; @@ -3740,7 +4071,31 @@ sub pp_padsv { } sub pp_padav { pp_padsv(@_) } -sub pp_padhv { pp_padsv(@_) } + +# prepend 'keys' where its been optimised away, with suitable handling +# of CORE:: and parens + +sub add_keys_keyword { + my ($self, $str, $cx) = @_; + $str = $self->maybe_parens($str, $cx, 16); + # 'keys %h' versus 'keys(%h)' + $str = " $str" unless $str =~ /^\(/; + return $self->keyword("keys") . $str; +} + +sub pp_padhv { + my ($self, $op, $cx) = @_; + my $str = pp_padsv(@_); + # with OPpPADHV_ISKEYS the keys op is optimised away, except + # in scalar context the old op is kept (but not executed) so its targ + # can be used. + if ( ($op->private & OPpPADHV_ISKEYS) + && !(($op->flags & OPf_WANT) == OPf_WANT_SCALAR)) + { + $str = $self->add_keys_keyword($str, $cx); + } + $str; +} sub gv_or_padgv { my $self = shift; @@ -3764,7 +4119,7 @@ sub pp_gv { my $self = shift; my($op, $cx) = @_; my $gv = $self->gv_or_padgv($op); - return $self->gv_name($gv); + return $self->maybe_qualify("", $self->gv_name($gv)); } sub pp_aelemfast_lex { @@ -3801,7 +4156,8 @@ sub rv2x { } my $kid = $op->first; if ($kid->name eq "gv") { - return $self->stash_variable($type, $self->deparse($kid, 0), $cx); + return $self->stash_variable($type, + $self->gv_name($self->gv_or_padgv($kid)), $cx); } elsif (is_scalar $kid) { my $str = $self->deparse($kid, 0); if ($str =~ /^\$([^\w\d])\z/) { @@ -3823,18 +4179,43 @@ sub rv2x { } sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) } -sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) } sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) } +sub pp_rv2hv { + my ($self, $op, $cx) = @_; + my $str = rv2x(@_, "%"); + if ($op->private & OPpRV2HV_ISKEYS) { + $str = $self->add_keys_keyword($str, $cx); + } + return maybe_local(@_, $str); +} + # skip rv2av sub pp_av2arylen { my $self = shift; my($op, $cx) = @_; - if ($op->first->name eq "padav") { - return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first)); + my $kid = $op->first; + if ($kid->name eq "padav") { + return $self->maybe_local($op, $cx, '$#' . $self->padany($kid)); } else { - return $self->maybe_local($op, $cx, - $self->rv2x($op->first, $cx, '$#')); + my $kkid; + if ( $kid->name eq "rv2av" + && ($kkid = $kid->first) + && $kkid->name !~ /^(scope|leave|gv)$/) + { + # handle (expr)->$#* postfix form + my $expr; + $expr = $self->deparse($kkid, 24); # 24 is '->' + $expr = "$expr->\$#*"; + # XXX maybe_local is probably wrong here: local($#-expression) + # doesn't "do" local (the is no INTRO flag set) + return $self->maybe_local($op, $cx, $expr); + } + else { + # handle $#{expr} form + # XXX see maybe_local comment above + return $self->maybe_local($op, $cx, $self->rv2x($kid, $cx, '$#')); + } } } @@ -4004,6 +4385,146 @@ sub multideref_var_name { } +# deparse an OP_MULTICONCAT. If $in_dq is 1, we're within +# a double-quoted string, so for example. +# "abc\Qdef$x\Ebar" +# might get compiled as +# multiconcat("abc", metaquote(multiconcat("def", $x)), "bar") +# and the inner multiconcat should be deparsed as C<def$x> rather than +# the normal C<def . $x> +# Ditto if $in_dq is 2, handle qr/...\Qdef$x\E.../. + +sub do_multiconcat { + my $self = shift; + my($op, $cx, $in_dq) = @_; + + my $kid; + my @kids; + my $assign; + my $append; + my $lhs = ""; + + for ($kid = $op->first; !null $kid; $kid = $kid->sibling) { + # skip the consts and/or padsv we've optimised away + push @kids, $kid + unless $kid->type == OP_NULL + && ( $kid->targ == OP_PADSV + || $kid->targ == OP_CONST + || $kid->targ == OP_PUSHMARK); + } + + $append = ($op->private & OPpMULTICONCAT_APPEND); + + if ($op->private & OPpTARGET_MY) { + # '$lex = ...' or '$lex .= ....' or 'my $lex = ' + $lhs = $self->padname($op->targ); + $lhs = "my $lhs" if ($op->private & OPpLVAL_INTRO); + $assign = 1; + } + elsif ($op->flags & OPf_STACKED) { + # 'expr = ...' or 'expr .= ....' + my $expr = $append ? shift(@kids) : pop(@kids); + $lhs = $self->deparse($expr, 7); + $assign = 1; + } + + if ($assign) { + $lhs .= $append ? ' .= ' : ' = '; + } + + my ($nargs, $const_str, @const_lens) = $op->aux_list($self->{curcv}); + + my @consts; + my $i = 0; + for (@const_lens) { + if ($_ == -1) { + push @consts, undef; + } + else { + push @consts, substr($const_str, $i, $_); + my @args; + $i += $_; + } + } + + my $rhs = ""; + + if ( $in_dq + || (($op->private & OPpMULTICONCAT_STRINGIFY) && !$self->{'unquote'})) + { + # "foo=$foo bar=$bar " + my $not_first; + while (@consts) { + if ($not_first) { + my $s = $self->dq(shift(@kids), 18); + # don't deparse "a${$}b" as "a$$b" + $s = '${$}' if $s eq '$$'; + $rhs = dq_disambiguate($rhs, $s); + } + $not_first = 1; + my $c = shift @consts; + if (defined $c) { + if ($in_dq == 2) { + # in pattern: don't convert newline to '\n' etc etc + my $s = re_uninterp(escape_re(re_unback($c))); + $rhs = re_dq_disambiguate($rhs, $s) + } + else { + my $s = uninterp(escape_str(unback($c))); + $rhs = dq_disambiguate($rhs, $s) + } + } + } + return $rhs if $in_dq; + $rhs = single_delim("qq", '"', $rhs, $self); + } + elsif ($op->private & OPpMULTICONCAT_FAKE) { + # sprintf("foo=%s bar=%s ", $foo, $bar) + + my @all; + @consts = map { $_ //= ''; s/%/%%/g; $_ } @consts; + my $fmt = join '%s', @consts; + push @all, $self->quoted_const_str($fmt); + + # the following is a stripped down copy of sub listop {} + my $parens = $assign || ($cx >= 5) || $self->{'parens'}; + my $fullname = $self->keyword('sprintf'); + push @all, map $self->deparse($_, 6), @kids; + + $rhs = $parens + ? "$fullname(" . join(", ", @all) . ")" + : "$fullname " . join(", ", @all); + } + else { + # "foo=" . $foo . " bar=" . $bar + my @all; + my $not_first; + while (@consts) { + push @all, $self->deparse(shift(@kids), 18) if $not_first; + $not_first = 1; + my $c = shift @consts; + if (defined $c) { + push @all, $self->quoted_const_str($c); + } + } + $rhs .= join ' . ', @all; + } + + my $text = $lhs . $rhs; + + $text = "($text)" if ($cx >= (($assign) ? 7 : 18+1)) + || $self->{'parens'}; + + return $text; +} + + +sub pp_multiconcat { + my $self = shift; + $self->do_multiconcat(@_, 0); +} + + sub pp_multideref { my $self = shift; my($op, $cx) = @_; @@ -4021,7 +4542,11 @@ sub pp_multideref { if ($op->first && ($op->first->flags & OPf_KIDS)) { # arbitrary initial expression, e.g. f(1,2,3)->[...] - $text .= $self->deparse($op->first, 24); + my $expr = $self->deparse($op->first, 24); + # stop "exists (expr)->{...}" being interpreted as + #"(exists (expr))->{...}" + $expr = "+$expr" if $expr =~ /^\(/; + $text .= $expr; } my @items = $op->aux_list($self->{curcv}); @@ -4139,6 +4664,7 @@ sub pp_gelem { my $scope = is_scope($glob); $glob = $self->deparse($glob, 0); $part = $self->deparse($part, 1); + $glob =~ s/::\z// unless $scope; return "*" . ($scope ? "{$glob}" : $glob) . "{$part}"; } @@ -4167,8 +4693,9 @@ sub slice { } else { $list = $self->elem_or_slice_single_index($kid); } - my $lead = '@'; - $lead = '%' if $op->name =~ /^kv/i; + my $lead = ( _op_is_or_was($op, OP_KVHSLICE) + || _op_is_or_was($op, OP_KVASLICE)) + ? '%' : '@'; return $lead . $array . $left . $list . $right; } @@ -4381,7 +4908,7 @@ sub retscalar { |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_subtract|concat|multiconcat|stringify|left_shift|right_shift|lt |i_lt|gt|i_gt|le|i_le|ge|i_ge|eq|i_eq|ne|i_ne|ncmp|i_ncmp |slt|sgt|sle|sge|seq|sne|scmp|[sn]?bit_(?:and|x?or)|negate |i_negate|not|[sn]?complement|smartmatch|atan2|sin|cos @@ -4443,7 +4970,7 @@ sub pp_entersub { $proto = $cv->PV if $cv->FLAGS & SVf_POK; } $simple = 1; # only calls of named functions can be prototyped - $kid = $self->deparse($kid, 24); + $kid = $self->maybe_qualify("!", $self->gv_name($gv)); my $fq; # Fully qualify any sub name that conflicts with a lexical. if ($self->lex_in_scope("&$kid") @@ -4655,11 +5182,33 @@ sub unback { # Remove backslashes which precede literal control characters, # to avoid creating ambiguity when we escape the latter. +# +# Don't remove a backslash from escaped whitespace: where the T represents +# a literal tab character, /T/x is not equivalent to /\T/x + sub re_unback { my($str) = @_; # the insane complexity here is due to the behaviour of "\c\" - $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g; + $str =~ s/ + # these two lines ensure that the backslash we're about to + # remove isn't preceeded by something which makes it part + # of a \c + + (^ | [^\\] | \\c\\) # $1 + (?<!\\c) + + # the backslash to remove + \\ + + # keep pairs of backslashes + (\\\\)* # $2 + + # only remove if the thing following is a control char + (?=[[:^print:]]) + # and not whitespace + (?=\S) + /$1$2/xg; return $str; } @@ -4735,6 +5284,20 @@ sub split_float { return ($mantissa, $exponent); } + +# suitably single- or double-quote a literal constant string + +sub quoted_const_str { + my ($self, $str) =@_; + if ($str =~ /[[:^print:]]/a) { + return single_delim("qq", '"', + uninterp(escape_str unback $str), $self); + } else { + return single_delim("q", "'", unback($str), $self); + } +} + + sub const { my $self = shift; my($sv, $cx) = @_; @@ -4820,13 +5383,8 @@ sub const { } return "{" . join(", ", @elts) . "}"; } elsif ($class eq "CV") { - BEGIN { - if ($] > 5.0150051) { - require overloading; - unimport overloading; - } - } - if ($] > 5.0150051 && $self->{curcv} && + no overloading; + if ($self->{curcv} && $self->{curcv}->object_2svref == $ref->object_2svref) { return $self->keyword("__SUB__"); } @@ -4848,12 +5406,7 @@ sub const { return $self->maybe_parens("\\$const", $cx, 20); } elsif ($sv->FLAGS & SVf_POK) { my $str = $sv->PV; - if ($str =~ /[[:^print:]]/a) { - return single_delim("qq", '"', - uninterp(escape_str unback $str), $self); - } else { - return single_delim("q", "'", unback($str), $self); - } + return $self->quoted_const_str($str); } else { return "undef"; } @@ -4913,6 +5466,25 @@ sub pp_const { return $self->const($sv, $cx); } + +# Join two components of a double-quoted string, disambiguating +# "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar" + +sub dq_disambiguate { + my ($first, $last) = @_; + ($last =~ /^[A-Z\\\^\[\]_?]/ && + $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc + || ($last =~ /^[:'{\[\w_]/ && #' + $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/); + return $first . $last; +} + + +# Deparse a double-quoted optree. For example, "$a[0]\Q$b\Efo\"o" gets +# compiled to concat(concat($[0],quotemeta($b)),const("fo\"o")), and this +# sub deparses it back to $a[0]\Q$b\Efo"o +# (It does not add delimiters) + sub dq { my $self = shift; my $op = shift; @@ -4921,16 +5493,9 @@ sub dq { return '$[' if $op->private & OPpCONST_ARYBASE; return uninterp(escape_str(unback($self->const_sv($op)->as_string))); } elsif ($type eq "concat") { - my $first = $self->dq($op->first); - my $last = $self->dq($op->last); - - # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar" - ($last =~ /^[A-Z\\\^\[\]_?]/ && - $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc - || ($last =~ /^[:'{\[\w_]/ && #' - $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/); - - return $first . $last; + return dq_disambiguate($self->dq($op->first), $self->dq($op->last)); + } elsif ($type eq "multiconcat") { + return $self->do_multiconcat($op, 26, 1); } elsif ($type eq "uc") { return '\U' . $self->dq($op->first->sibling) . '\E'; } elsif ($type eq "lc") { @@ -5019,7 +5584,9 @@ sub double_delim { } } +# Escape a characrter. # Only used by tr///, so backslashes hyphens + sub pchr { # ASCII my($n) = @_; if ($n == ord '\\') { @@ -5047,13 +5614,16 @@ sub pchr { # ASCII } elsif ($n == ord "\r") { return '\\r'; } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) { - return '\\c' . unctrl{chr $n}; + return '\\c' . $unctrl{chr $n}; } else { # return '\x' . sprintf("%02x", $n); return '\\' . sprintf("%03o", $n); } } +# Convert a list of characters into a string suitable for tr/// search or +# replacement, with suitable escaping and collapsing of ranges + sub collapse { my(@chars) = @_; my($str, $c, $tr) = (""); @@ -5074,8 +5644,10 @@ sub collapse { sub tr_decode_byte { my($table, $flags) = @_; - my(@table) = unpack("s*", $table); - splice @table, 0x100, 1; # Number of subsequent elements + my $ssize_t = $Config{ptrsize} == 8 ? 'q' : 'l'; + my ($size, @table) = unpack("${ssize_t}s*", $table); + pop @table; # remove the wildcard final entry + my($c, $tr, @from, @to, @delfrom, $delhyphen); if ($table[ord "-"] != -1 and $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1) @@ -5098,7 +5670,12 @@ sub tr_decode_byte { } } @from = (@from, @delfrom); + if ($flags & OPpTRANS_COMPLEMENT) { + unless ($flags & OPpTRANS_DELETE) { + @to = () if ("@from" eq "@to"); + } + my @newfrom = (); my %from; @from{@from} = (1) x @from; @@ -5255,9 +5832,11 @@ sub pp_trans { sub pp_transr { push @_, 'r'; goto &pp_trans } +# Join two components of a double-quoted re, disambiguating +# "${foo}bar", "${foo}{bar}", "${foo}[1]". + sub re_dq_disambiguate { my ($first, $last) = @_; - # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]" ($last =~ /^[A-Z\\\^\[\]_?]/ && $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc || ($last =~ /^[{\[\w_]/ && @@ -5279,6 +5858,8 @@ sub re_dq { my $first = $self->re_dq($op->first); my $last = $self->re_dq($op->last); return re_dq_disambiguate($first, $last); + } elsif ($type eq "multiconcat") { + return $self->do_multiconcat($op, 26, 2); } elsif ($type eq "uc") { return '\U' . $self->re_dq($op->first->sibling) . '\E'; } elsif ($type eq "lc") { @@ -5327,6 +5908,31 @@ sub pure_string { return $self->pure_string($op->first) && $self->pure_string($op->last); } + elsif ($type eq 'multiconcat') { + my ($kid, @kids); + for ($kid = $op->first; !null $kid; $kid = $kid->sibling) { + # skip the consts and/or padsv we've optimised away + push @kids, $kid + unless $kid->type == OP_NULL + && ( $kid->targ == OP_PADSV + || $kid->targ == OP_CONST + || $kid->targ == OP_PUSHMARK); + } + + if ($op->flags & OPf_STACKED) { + # remove expr from @kids where 'expr = ...' or 'expr .= ....' + if ($op->private & OPpMULTICONCAT_APPEND) { + shift(@kids); + } + else { + pop(@kids); + } + } + for (@kids) { + return 0 unless $self->pure_string($_); + } + return 1; + } elsif (is_scalar($op) || $type =~ /^[ah]elem$/) { return 1; } @@ -5478,7 +6084,7 @@ sub matchop { my($op, $cx, $name, $delim) = @_; my $kid = $op->first; my ($binop, $var, $re) = ("", "", ""); - if ($op->flags & OPf_STACKED) { + if ($op->name ne 'split' && $op->flags & OPf_STACKED) { $binop = 1; $var = $self->deparse($kid, 20); $kid = $kid->sibling; @@ -5517,7 +6123,13 @@ sub matchop { } elsif (!$have_kid) { $re = re_uninterp(escape_re(re_unback($op->precomp))); } elsif ($kid->name ne 'regcomp') { - carp("found ".$kid->name." where regcomp expected"); + if ($op->name eq 'split') { + # split has other kids, not just regcomp + $re = re_uninterp(escape_re(re_unback($op->precomp))); + } + else { + carp("found ".$kid->name." where regcomp expected"); + } } else { ($re, $quote) = $self->regcomp($kid, 21); } @@ -5557,64 +6169,58 @@ sub matchop { } sub pp_match { matchop(@_, "m", "/") } -sub pp_pushre { matchop(@_, "m", "/") } sub pp_qr { matchop(@_, "qr", "") } sub pp_runcv { unop(@_, "__SUB__"); } sub pp_split { - maybe_targmy(@_, \&split); -} -sub split { my $self = shift; my($op, $cx) = @_; my($kid, @exprs, $ary, $expr); + my $stacked = $op->flags & OPf_STACKED; + $kid = $op->first; + $kid = $kid->sibling if $kid->name eq 'regcomp'; + for (; !null($kid); $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } - # For our kid (an OP_PUSHRE), pmreplroot is never actually the - # root of a replacement; it's either empty, or abused to point to - # the GV for an array we split into (an optimization to save - # assignment overhead). Depending on whether we're using ithreads, - # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs - # figures out for us which it is. - my $replroot = $kid->pmreplroot; - my $gv = 0; - my $stacked = $op->flags & OPf_STACKED; - if (ref($replroot) eq "B::GV") { - $gv = $replroot; - } elsif (!ref($replroot) and $replroot > 0) { - $gv = $self->padval($replroot); - } elsif ($kid->targ) { - $ary = $self->padname($kid->targ) - } elsif ($stacked) { - $ary = $self->deparse($op->last, 7); - } - $ary = $self->maybe_local(@_, + unshift @exprs, $self->matchop($op, $cx, "m", "/"); + + if ($op->private & OPpSPLIT_ASSIGN) { + # With C<@array = split(/pat/, str);>, + # array is stored in split's pmreplroot; either + # as an integer index into the pad (for a lexical array) + # or as GV for a package array (which will be a pad index + # on threaded builds) + # With my/our @array = split(/pat/, str), the array is instead + # accessed via an extra padav/rv2av op at the end of the + # split's kid ops. + + if ($stacked) { + $ary = pop @exprs; + } + else { + if ($op->private & OPpSPLIT_LEX) { + $ary = $self->padname($op->pmreplroot); + } + else { + # union with op_pmtargetoff, op_pmtargetgv + my $gv = $op->pmreplroot; + $gv = $self->padval($gv) if !ref($gv); + $ary = $self->maybe_local(@_, $self->stash_variable('@', $self->gv_name($gv), $cx)) - if $gv; - - # Skip the last kid when OPf_STACKED is set, since it is the array - # on the left. - for (; !null($stacked ? $kid->sibling : $kid); $kid = $kid->sibling) { - push @exprs, $self->deparse($kid, 6); + } + if ($op->private & OPpLVAL_INTRO) { + $ary = $op->private & OPpSPLIT_LEX ? "my $ary" : "local $ary"; + } + } } # handle special case of split(), and split(' ') that compiles to /\s+/ - # Under 5.10, the reflags may be undef if the split regexp isn't a constant - # Under 5.17.5-5.17.9, the special flag is on split itself. - $kid = $op->first; - if ( $op->flags & OPf_SPECIAL - or ( - $kid->flags & OPf_SPECIAL - and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE() - : ($kid->reflags || 0) & RXf_SKIPWHITE() - ) - ) - ) { - $exprs[0] = "' '"; - } + $exprs[0] = q{' '} if ($op->reflags // 0) & RXf_SKIPWHITE(); $expr = "split(" . join(", ", @exprs) . ")"; if ($ary) { @@ -5772,6 +6378,63 @@ sub pp_lvavref { : &pp_padsv) . ')' } + +sub pp_argcheck { + my $self = shift; + my($op, $cx) = @_; + my ($params, $opt_params, $slurpy) = $op->aux_list($self->{curcv}); + my $mandatory = $params - $opt_params; + my $check = ''; + + $check .= <<EOF if !$slurpy; +die sprintf("Too many arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ <= $params; +EOF + + $check .= <<EOF if $mandatory > 0; +die sprintf("Too few arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ >= $mandatory; +EOF + + my $cond = ($params & 1) ? 'unless' : 'if'; + $check .= <<EOF if $slurpy eq '%'; +die sprintf("Odd name/value argument for subroutine at %s line %d.\\n", (caller)[1, 2]) if \@_ > $params && ((\@_ - $params) & 1); +EOF + + $check =~ s/;\n\z//; + return $check; +} + + +sub pp_argelem { + my $self = shift; + my($op, $cx) = @_; + my $var = $self->padname($op->targ); + my $ix = $op->string($self->{curcv}); + my $expr; + if ($op->flags & OPf_KIDS) { + $expr = $self->deparse($op->first, 7); + } + elsif ($var =~ /^[@%]/) { + $expr = $ix ? "\@_[$ix .. \$#_]" : '@_'; + } + else { + $expr = "\$_[$ix]"; + } + return "my $var = $expr"; +} + + +sub pp_argdefelem { + my $self = shift; + my($op, $cx) = @_; + my $ix = $op->targ; + my $expr = "\@_ >= " . ($ix+1) . " ? \$_[$ix] : "; + my $def = $self->deparse($op->first, 7); + $def = "($def)" if $op->first->flags & OPf_PARENS; + $expr .= $self->deparse($op->first, $cx); + return $expr; +} + + 1; __END__ @@ -6110,7 +6773,7 @@ expect. =item $[ Takes a number, the value of the array base $[. -Cannot be non-zero on Perl 5.15.3 or later. +Obsolete: cannot be non-zero. =item bytes @@ -6197,11 +6860,10 @@ the main:: package, the code will include a package declaration. =item * -In Perl 5.20 and earlier, the only pragmas to +The only pragmas to be completely supported are: C<use warnings>, C<use strict>, C<use bytes>, C<use integer> -and C<use feature>. (C<$[>, which -behaves like a pragma, is also supported.) +and C<use feature>. Excepting those listed above, we're currently unable to guarantee that B::Deparse will produce a pragma at the correct point in the program. @@ -6219,9 +6881,6 @@ 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 problem in Perl 5.20 and earlier. Fixing this -required internal changes in Perl 5.22. - =item * Some constants don't print correctly either with or without B<-d>. @@ -6256,7 +6915,7 @@ which is not, consequently, deparsed correctly. =item * Lexical (my) variables declared in scopes external to a subroutine -appear in code2ref output text as package variables. This is a tricky +appear in coderef2text output text as package variables. This is a tricky problem, as perl has no native facility for referring to a lexical variable defined within a different scope, although L<PadWalker> is a good start. @@ -6267,12 +6926,6 @@ L<PadWalker> to serialize closures properly. There are probably many more bugs on non-ASCII platforms (EBCDIC). -=item * - -Prior to Perl 5.22, lexical C<my> subroutines were not deparsed properly. -They were emitted as pure declarations, sometimes in the wrong place. -Lexical C<state> subroutines were not deparsed at all. - =back =head1 AUTHOR diff --git a/gnu/usr.bin/perl/lib/B/Deparse.t b/gnu/usr.bin/perl/lib/B/Deparse.t index 19db4040bca..2451ce5e774 100644 --- a/gnu/usr.bin/perl/lib/B/Deparse.t +++ b/gnu/usr.bin/perl/lib/B/Deparse.t @@ -1,7 +1,7 @@ #!./perl BEGIN { - unshift @INC, 't'; + splice @INC, 0, 0, 't', '.'; require Config; if (($Config::Config{'extensions'} !~ /\bB\b/) ){ print "1..0 # Skip -- Perl configured without B module\n"; @@ -13,7 +13,7 @@ BEGIN { use warnings; use strict; -my $tests = 46; # not counting those in the __DATA__ section +my $tests = 52; # not counting those in the __DATA__ section use B::Deparse; my $deparse = B::Deparse->new(); @@ -63,7 +63,7 @@ while (<DATA>) { new B::Deparse split /,/, $meta{options} : $deparse; - my $coderef = eval "$meta{context};\n" . <<'EOC' . "sub {$input\n}"; + my $code = "$meta{context};\n" . <<'EOC' . "sub {$input\n}"; # Tell B::Deparse about our ambient pragmas my ($hint_bits, $warning_bits, $hinthash); BEGIN { @@ -75,10 +75,14 @@ $deparse->ambient_pragmas ( '%^H' => $hinthash, ); EOC + my $coderef = eval $code; local $::TODO = $meta{todo}; if ($@) { - is($@, "", "compilation of $desc"); + is($@, "", "compilation of $desc") + or diag "=============================================\n" + . "CODE:\n--------\n$code\n--------\n" + . "=============================================\n"; } else { my $deparsed = $deparse->coderef2text( $coderef ); @@ -87,7 +91,12 @@ EOC $regex =~ s/\s+/\\s+/g; $regex = '^\{\s*' . $regex . '\s*\}$'; - like($deparsed, qr/$regex/, $desc); + like($deparsed, qr/$regex/, $desc) + or diag "=============================================\n" + . "CODE:\n--------\n$input\n--------\n" + . "EXPECTED:\n--------\n{\n$expected\n}\n--------\n" + . "GOT:\n--------\n$deparsed\n--------\n" + . "=============================================\n"; } } @@ -143,6 +152,21 @@ $a =~ s/-e syntax OK\n//g; is($a, "use constant ('PI', 4);\n", "Proxy Constant Subroutines must not show up as (incorrect) prototypes"); +$a = `$^X $path "-MO=Deparse" -e "sub foo(){1}" 2>&1`; +$a =~ s/-e syntax OK\n//g; +is($a, "sub foo () {\n 1;\n}\n", + "Main prog consisting of just a constant (via empty proto)"); + +$a = readpipe qq|$^X $path "-MO=Deparse"| + .qq| -e "package F; sub f(){0} sub s{}"| + .qq| -e "#line 123 four-five-six"| + .qq| -e "package G; sub g(){0} sub s{}" 2>&1|; +$a =~ s/-e syntax OK\n//g; +like($a, qr/sub F::f \(\) \{\s*0;?\s*}/, + "Constant is dumped in package in which other subs are dumped"); +unlike($a, qr/sub g/, + "Constant is not dumped in package in which other subs are not dumped"); + #Re: perlbug #35857, patch #24505 #handle warnings::register-ed packages properly. package B::Deparse::Wrapper; @@ -363,20 +387,20 @@ EOCODP # CORE::no $a = readpipe qq`$^X $path "-MO=Deparse" -Xe ` .qq`"use feature q|:all|; my sub no; CORE::no less" 2>&1`; -like($a, qr/my sub no;\nCORE::no less;/, +like($a, qr/my sub no;\n.*CORE::no less;/s, 'CORE::no after my sub no'); # CORE::use $a = readpipe qq`$^X $path "-MO=Deparse" -Xe ` .qq`"use feature q|:all|; my sub use; CORE::use less" 2>&1`; -like($a, qr/my sub use;\nCORE::use less;/, +like($a, qr/my sub use;\n.*CORE::use less;/s, 'CORE::use after my sub use'); # CORE::__DATA__ $a = readpipe qq`$^X $path "-MO=Deparse" -Xe ` .qq`"use feature q|:all|; my sub __DATA__; ` .qq`CORE::__DATA__" 2>&1`; -like($a, qr/my sub __DATA__;\n.*\nCORE::__DATA__/s, +like($a, qr/my sub __DATA__;\n.*CORE::__DATA__/s, 'CORE::__DATA__ after my sub __DATA__'); # sub declarations @@ -522,6 +546,22 @@ unlike runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path, '-w' ], qr'Use of uninitialized value', 'no warnings for undefined sub'; +is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], + prog => 'sub f { 1; } BEGIN { *g = \&f; }'), + "sub f {\n 1;\n}\nsub BEGIN {\n *g = \\&f;\n}\n", + "sub glob alias shouldn't impede emitting original sub"; + +is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], + prog => 'package Foo; sub f { 1; } BEGIN { *g = \&f; }'), + "package Foo;\nsub f {\n 1;\n}\nsub BEGIN {\n *g = \\&f;\n}\n", + "sub glob alias outside main shouldn't impede emitting original sub"; + +is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], + prog => 'package Foo; sub f { 1; } BEGIN { *Bar::f = \&f; }'), + "package Foo;\nsub f {\n 1;\n}\nsub BEGIN {\n *Bar::f = \\&f;\n}\n", + "sub glob alias in separate package shouldn't impede emitting original sub"; + + done_testing($tests); __DATA__ @@ -780,12 +820,38 @@ print $_ foreach (reverse 1, 2..5); our @ary; @ary = split(' ', 'foo', 0); #### +my @ary; +@ary = split(' ', 'foo', 0); +#### # Split to our array our @array = split(//, 'foo', 0); #### # Split to my array my @array = split(//, 'foo', 0); #### +our @array; +my $c; +@array = split(/x(?{ $c++; })y/, 'foo', 0); +#### +my($x, $y, $p); +our $c; +($x, $y) = split(/$p(?{ $c++; })y/, 'foo', 2); +#### +our @ary; +my $pat; +@ary = split(/$pat/, 'foo', 0); +#### +my @ary; +our $pat; +@ary = split(/$pat/, 'foo', 0); +#### +our @array; +my $pat; +local @array = split(/$pat/, 'foo', 0); +#### +our $pat; +my @array = split(/$pat/, 'foo', 0); +#### # bug #40055 do { () }; #### @@ -1372,11 +1438,48 @@ s/X//r; use feature 'unicode_strings'; s/X//d; #### -# all the flags (tr///) -tr/X/Y/c; -tr/X//d; -tr/X//s; -tr/X//r; +# tr/// with all the flags: empty replacement +tr/B-G//; +tr/B-G//c; +tr/B-G//d; +tr/B-G//s; +tr/B-G//cd; +tr/B-G//ds; +tr/B-G//cs; +tr/B-G//cds; +tr/B-G//r; +#### +# tr/// with all the flags: short replacement +tr/B-G/b/; +tr/B-G/b/c; +tr/B-G/b/d; +tr/B-G/b/s; +tr/B-G/b/cd; +tr/B-G/b/ds; +tr/B-G/b/cs; +tr/B-G/b/cds; +tr/B-G/b/r; +#### +# tr/// with all the flags: equal length replacement +tr/B-G/b-g/; +tr/B-G/b-g/c; +tr/B-G/b-g/s; +tr/B-G/b-g/cs; +tr/B-G/b-g/r; +#### +# tr with extended table (/c) +tr/\000-\375/AB/c; +tr/\000-\375/A-C/c; +tr/\000-\375/A-D/c; +tr/\000-\375/A-I/c; +tr/\000-\375/AB/cd; +tr/\000-\375/A-C/cd; +tr/\000-\375/A-D/cd; +tr/\000-\375/A-I/cd; +tr/\000-\375/AB/cds; +tr/\000-\375/A-C/cds; +tr/\000-\375/A-D/cds; +tr/\000-\375/A-I/cds; #### # [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns) s/foo/\(3);/eg; @@ -1941,36 +2044,28 @@ my($a, $b, $c) = @_; #### # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" # lexical subroutine -use feature 'lexical_subs'; +# CONTEXT use feature 'lexical_subs'; no warnings "experimental::lexical_subs"; my sub f {} print f(); >>>> -use feature 'lexical_subs'; -BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x15"} +BEGIN {${^WARNING_BITS} = "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x55"} my sub f { - BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x15"} } -BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x15"} print f(); #### # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" # lexical "state" subroutine -use feature 'state', 'lexical_subs'; +# CONTEXT use feature 'state', 'lexical_subs'; no warnings 'experimental::lexical_subs'; state sub f {} print f(); >>>> -use feature 'lexical_subs'; -BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x15"} -CORE::state sub f { - BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x15"} - use feature 'state'; +BEGIN {${^WARNING_BITS} = "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x55"} +state sub f { } -BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x15"} -use feature 'state'; print f(); #### # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" @@ -2461,12 +2556,17 @@ my $e = delete $h{'foo'}[$i]; #### # multideref with leading expression my $r; -my $x = ($r // [])->{'foo'}[0]; +my $x = +($r // [])->{'foo'}[0]; #### # multideref with complex middle index my(%h, $i, $j, $k); my $x = $h{'foo'}[$i + $j]{$k}; #### +# multideref with trailing non-simple index that initially looks simple +# (i.e. the constant "3") +my($r, $i, $j, $k); +my $x = +($r || {})->{'foo'}[$i + $j]{3 + $k}; +#### # chdir chdir 'file'; chdir FH; @@ -2488,3 +2588,478 @@ $_ ^= $_; $_ |.= $_; $_ &.= $_; $_ ^.= $_; +#### +#### +# Should really use 'no warnings "experimental::signatures"', +# but it doesn't yet deparse correctly. +# anon subs used because this test framework doesn't deparse named subs +# in the DATA code snippets. +# +# general signature +no warnings; +use feature 'signatures'; +my $x; +sub ($a, $, $b = $glo::bal, $c = $a, $d = 'foo', $e = -37, $f = 0, $g = 1, $h = undef, $i = $a + 1, $j = /foo/, @) { + $x++; +} +; +$x++; +#### +# Signature and prototype +no warnings; +use feature 'signatures'; +my $x; +my $f = sub : prototype($$) ($a, $b) { + $x++; +} +; +$x++; +#### +# Signature and prototype and attrs +no warnings; +use feature 'signatures'; +my $x; +my $f = sub : prototype($$) lvalue ($a, $b) { + $x++; +} +; +$x++; +#### +# Signature and attrs +no warnings; +use feature 'signatures'; +my $x; +my $f = sub : lvalue method ($a, $b) { + $x++; +} +; +$x++; +#### +# named array slurp, null body +no warnings; +use feature 'signatures'; +sub (@a) { + ; +} +; +#### +# named hash slurp +no warnings; +use feature 'signatures'; +sub ($key, %h) { + $h{$key}; +} +; +#### +# anon hash slurp +no warnings; +use feature 'signatures'; +sub ($a, %) { + $a; +} +; +#### +# parenthesised default arg +no warnings; +use feature 'signatures'; +sub ($a, $b = (/foo/), $c = 1) { + $a + $b + $c; +} +; +#### +# parenthesised default arg with TARGMY +no warnings; +use feature 'signatures'; +sub ($a, $b = ($a + 1), $c = 1) { + $a + $b + $c; +} +; +#### +# empty default +no warnings; +use feature 'signatures'; +sub ($a, $=) { + $a; +} +; +#### +# padrange op within pattern code blocks +/(?{ my($x, $y) = (); })/; +my $a; +/$a(?{ my($x, $y) = (); })/; +my $r1 = qr/(?{ my($x, $y) = (); })/; +my $r2 = qr/$a(?{ my($x, $y) = (); })/; +#### +# don't remove pattern whitespace escapes +/a\ b/; +/a\ b/x; +/a\ b/; +/a\ b/x; +#### +# my attributes +my $s1 :foo(f1, f2) bar(b1, b2); +my @a1 :foo(f1, f2) bar(b1, b2); +my %h1 :foo(f1, f2) bar(b1, b2); +my($s2, @a2, %h2) :foo(f1, f2) bar(b1, b2); +#### +# my class attributes +package Foo::Bar; +my Foo::Bar $s1 :foo(f1, f2) bar(b1, b2); +my Foo::Bar @a1 :foo(f1, f2) bar(b1, b2); +my Foo::Bar %h1 :foo(f1, f2) bar(b1, b2); +my Foo::Bar ($s2, @a2, %h2) :foo(f1, f2) bar(b1, b2); +package main; +my Foo::Bar $s3 :foo(f1, f2) bar(b1, b2); +my Foo::Bar @a3 :foo(f1, f2) bar(b1, b2); +my Foo::Bar %h3 :foo(f1, f2) bar(b1, b2); +my Foo::Bar ($s4, @a4, %h4) :foo(f1, f2) bar(b1, b2); +#### +# avoid false positives in my $x :attribute +'attributes'->import('main', \my $x1, 'foo(bar)'), my $y1; +'attributes'->import('Fooo', \my $x2, 'foo(bar)'), my $y2; +#### +# hash slices and hash key/value slices +my(@a, %h); +our(@oa, %oh); +@a = @h{'foo', 'bar'}; +@a = %h{'foo', 'bar'}; +@a = delete @h{'foo', 'bar'}; +@a = delete %h{'foo', 'bar'}; +@oa = @oh{'foo', 'bar'}; +@oa = %oh{'foo', 'bar'}; +@oa = delete @oh{'foo', 'bar'}; +@oa = delete %oh{'foo', 'bar'}; +#### +# keys optimised away in void and scalar context +no warnings; +; +our %h1; +my($x, %h2); +%h1; +keys %h1; +$x = %h1; +$x = keys %h1; +%h2; +keys %h2; +$x = %h2; +$x = keys %h2; +#### +# eq,const optimised away for (index() == -1) +my($a, $b); +our $c; +$c = index($a, $b) == 2; +$c = rindex($a, $b) == 2; +$c = index($a, $b) == -1; +$c = rindex($a, $b) == -1; +$c = index($a, $b) != -1; +$c = rindex($a, $b) != -1; +$c = (index($a, $b) == -1); +$c = (rindex($a, $b) == -1); +$c = (index($a, $b) != -1); +$c = (rindex($a, $b) != -1); +#### +# eq,const,sassign,madmy optimised away for (index() == -1) +my($a, $b); +my $c; +$c = index($a, $b) == 2; +$c = rindex($a, $b) == 2; +$c = index($a, $b) == -1; +$c = rindex($a, $b) == -1; +$c = index($a, $b) != -1; +$c = rindex($a, $b) != -1; +$c = (index($a, $b) == -1); +$c = (rindex($a, $b) == -1); +$c = (index($a, $b) != -1); +$c = (rindex($a, $b) != -1); +#### +# plain multiconcat +my($a, $b, $c, $d, @a); +$d = length $a . $b . $c; +$d = length($a) . $b . $c; +print '' . $a; +push @a, ($a . '') * $b; +unshift @a, "$a" * ($b . ''); +print $a . 'x' . $b . $c; +print $a . 'x' . $b . $c, $d; +print $b . $c . ($a . $b); +print $b . $c . ($a . $b); +print $b . $c . @a; +print $a . "\x{100}"; +#### +# double-quoted multiconcat +my($a, $b, $c, $d, @a); +print "${a}x\x{100}$b$c"; +print "$a\Q$b\E$c\Ua$a\E\Lb$b\uc$c\E$a${b}c$c"; +print "A=$a[length 'b' . $c . 'd'] b=$b"; +print "A=@a B=$b"; +print "\x{101}$a\x{100}"; +$a = qr/\Q +$b $c +\x80 +\x{100} +\E$c +/; +#### +# sprintf multiconcat +my($a, $b, $c, $d, @a); +print sprintf("%s%s%%%sx%s\x{100}%s", $a, $b, $c, scalar @a, $d); +#### +# multiconcat with lexical assign +my($a, $b, $c, $d, $e, @a); +$d = 'foo' . $a; +$d = "foo$a"; +$d = $a . ''; +$d = 'foo' . $a . 'bar'; +$d = $a . $b; +$d = $a . $b . $c; +$d = $a . $b . $c . @a; +$e = ($d = $a . $b . $c); +$d = !$a . $b . $c; +$a = $b . $c . ($a . $b); +$e = f($d = !$a . $b) . $c; +$d = "${a}x\x{100}$b$c"; +f($d = !$a . $b . $c); +#### +# multiconcat with lexical my +my($a, $b, $c, $d, $e, @a); +my $d1 = 'foo' . $a; +my $d2 = "foo$a"; +my $d3 = $a . ''; +my $d4 = 'foo' . $a . 'bar'; +my $d5 = $a . $b; +my $d6 = $a . $b . $c; +my $e7 = ($d = $a . $b . $c); +my $d8 = !$a . $b . $c; +my $d9 = $b . $c . ($a . $b); +my $da = f($d = !$a . $b) . $c; +my $dc = "${a}x\x{100}$b$c"; +f(my $db = !$a . $b . $c); +my $dd = $a . $b . $c . @a; +#### +# multiconcat with lexical append +my($a, $b, $c, $d, $e, @a); +$d .= ''; +$d .= $a; +$d .= "$a"; +$d .= 'foo' . $a; +$d .= "foo$a"; +$d .= $a . ''; +$d .= 'foo' . $a . 'bar'; +$d .= $a . $b; +$d .= $a . $b . $c; +$d .= $a . $b . @a; +$e .= ($d = $a . $b . $c); +$d .= !$a . $b . $c; +$a .= $b . $c . ($a . $b); +$e .= f($d .= !$a . $b) . $c; +f($d .= !$a . $b . $c); +$d .= "${a}x\x{100}$b$c"; +#### +# multiconcat with expression assign +my($a, $b, $c, @a); +our($d, $e); +$d = 'foo' . $a; +$d = "foo$a"; +$d = $a . ''; +$d = 'foo' . $a . 'bar'; +$d = $a . $b; +$d = $a . $b . $c; +$d = $a . $b . @a; +$e = ($d = $a . $b . $c); +$a["-$b-"] = !$a . $b . $c; +$a[$b]{$c}{$d ? $a : $b . $c} = !$a . $b . $c; +$a = $b . $c . ($a . $b); +$e = f($d = !$a . $b) . $c; +$d = "${a}x\x{100}$b$c"; +f($d = !$a . $b . $c); +#### +# multiconcat with expression concat +my($a, $b, $c, @a); +our($d, $e); +$d .= 'foo' . $a; +$d .= "foo$a"; +$d .= $a . ''; +$d .= 'foo' . $a . 'bar'; +$d .= $a . $b; +$d .= $a . $b . $c; +$d .= $a . $b . @a; +$e .= ($d .= $a . $b . $c); +$a["-$b-"] .= !$a . $b . $c; +$a[$b]{$c}{$d ? $a : $b . $c} .= !$a . $b . $c; +$a .= $b . $c . ($a . $b); +$e .= f($d .= !$a . $b) . $c; +$d .= "${a}x\x{100}$b$c"; +f($d .= !$a . $b . $c); +#### +# multiconcat with CORE::sprintf +# CONTEXT sub sprintf {} +my($a, $b); +my $x = CORE::sprintf('%s%s', $a, $b); +#### +# multiconcat with backticks +my($a, $b); +our $x; +$x = `$a-$b`; +#### +# multiconcat within qr// +my($r, $a, $b); +$r = qr/abc\Q$a-$b\Exyz/; +#### +# tr with unprintable characters +my $str; +$str = 'foo'; +$str =~ tr/\cA//; +#### +# CORE::foo special case in bareword parsing +print $CORE::foo, $CORE::foo::bar; +print @CORE::foo, @CORE::foo::bar; +print %CORE::foo, %CORE::foo::bar; +print $CORE::foo{'a'}, $CORE::foo::bar{'a'}; +print &CORE::foo, &CORE::foo::bar; +print &CORE::foo(), &CORE::foo::bar(); +print \&CORE::foo, \&CORE::foo::bar; +print *CORE::foo, *CORE::foo::bar; +print stat CORE::foo::, stat CORE::foo::bar; +print CORE::foo:: 1; +print CORE::foo::bar 2; +#### +# trailing colons on glob names +no strict 'vars'; +$Foo::::baz = 1; +print $foo, $foo::, $foo::::; +print @foo, @foo::, @foo::::; +print %foo, %foo::, %foo::::; +print $foo{'a'}, $foo::{'a'}, $foo::::{'a'}; +print &foo, &foo::, &foo::::; +print &foo(), &foo::(), &foo::::(); +print \&foo, \&foo::, \&foo::::; +print *foo, *foo::, *foo::::; +print stat Foo, stat Foo::::; +print Foo 1; +print Foo:::: 2; +#### +# trailing colons mixed with CORE +no strict 'vars'; +print $CORE, $CORE::, $CORE::::; +print @CORE, @CORE::, @CORE::::; +print %CORE, %CORE::, %CORE::::; +print $CORE{'a'}, $CORE::{'a'}, $CORE::::{'a'}; +print &CORE, &CORE::, &CORE::::; +print &CORE(), &CORE::(), &CORE::::(); +print \&CORE, \&CORE::, \&CORE::::; +print *CORE, *CORE::, *CORE::::; +print stat CORE, stat CORE::::; +print CORE 1; +print CORE:::: 2; +print $CORE::foo, $CORE::foo::, $CORE::foo::::; +print @CORE::foo, @CORE::foo::, @CORE::foo::::; +print %CORE::foo, %CORE::foo::, %CORE::foo::::; +print $CORE::foo{'a'}, $CORE::foo::{'a'}, $CORE::foo::::{'a'}; +print &CORE::foo, &CORE::foo::, &CORE::foo::::; +print &CORE::foo(), &CORE::foo::(), &CORE::foo::::(); +print \&CORE::foo, \&CORE::foo::, \&CORE::foo::::; +print *CORE::foo, *CORE::foo::, *CORE::foo::::; +print stat CORE::foo::, stat CORE::foo::::; +print CORE::foo:: 1; +print CORE::foo:::: 2; +#### +# \&foo +my sub foo { + 1; +} +no strict 'vars'; +print \&main::foo; +print \&{foo}; +print \&bar; +use strict 'vars'; +print \&main::foo; +print \&{foo}; +print \&main::bar; +#### +# exists(&foo) +my sub foo { + 1; +} +no strict 'vars'; +print exists &main::foo; +print exists &{foo}; +print exists &bar; +use strict 'vars'; +print exists &main::foo; +print exists &{foo}; +print exists &main::bar; +# precedence of optimised-away 'keys' (OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS) +my($r1, %h1, $res); +our($r2, %h2); +$res = keys %h1; +$res = keys %h2; +$res = keys %$r1; +$res = keys %$r2; +$res = keys(%h1) / 2 - 1; +$res = keys(%h2) / 2 - 1; +$res = keys(%$r1) / 2 - 1; +$res = keys(%$r2) / 2 - 1; +#### +# ditto in presence of sub keys {} +# CONTEXT sub keys {} +no warnings; +my($r1, %h1, $res); +our($r2, %h2); +CORE::keys %h1; +CORE::keys(%h1) / 2; +$res = CORE::keys %h1; +$res = CORE::keys %h2; +$res = CORE::keys %$r1; +$res = CORE::keys %$r2; +$res = CORE::keys(%h1) / 2 - 1; +$res = CORE::keys(%h2) / 2 - 1; +$res = CORE::keys(%$r1) / 2 - 1; +$res = CORE::keys(%$r2) / 2 - 1; +#### +# concat: STACKED: ambiguity between .= and optimised nested +my($a, $b); +$b = $a . $a . $a; +(($a .= $a) .= $a) .= $a; +#### +# multiconcat: $$ within string +my($a, $x); +$x = "${$}abc"; +$x = "\$$a"; +#### +# single state aggregate assignment +# CONTEXT use feature "state"; +state @a = (1, 2, 3); +state %h = ('a', 1, 'b', 2); +#### +# state var with attribute +# CONTEXT use feature "state"; +state $x :shared; +state $y :shared = 1; +state @a :shared; +state @b :shared = (1, 2); +state %h :shared; +state %i :shared = ('a', 1, 'b', 2); +#### +# \our @a shouldn't be a list +my $r = \our @a; +my(@l) = \our((@b)); +@l = \our(@c, @d); +#### +# postfix $# +our(@b, $s, $l); +$l = (\my @a)->$#*; +(\@b)->$#* = 1; +++(\my @c)->$#*; +$l = $#a; +$#a = 1; +$l = $#b; +$#b = 1; +my $r; +$l = $r->$#*; +$r->$#* = 1; +$l = $#{@$r;}; +$#{$r;} = 1; +$l = $s->$#*; +$s->$#* = 1; +$l = $#{@$s;}; +$#{$s;} = 1; diff --git a/gnu/usr.bin/perl/lib/B/Op_private.pm b/gnu/usr.bin/perl/lib/B/Op_private.pm index 9ab71ae9959..58953e1eee4 100644 --- a/gnu/usr.bin/perl/lib/B/Op_private.pm +++ b/gnu/usr.bin/perl/lib/B/Op_private.pm @@ -118,7 +118,7 @@ package B::Op_private; our %bits; -our $VERSION = "5.024003"; +our $VERSION = "5.028001"; $bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv); $bits{$_}{6} = 'OPpENTERSUB_DB' for qw(entersub rv2cv); @@ -130,14 +130,15 @@ $bits{$_}{2} = 'OPpFT_STACKED' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir $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} = 'OPpHINT_STRICT_REFS' for qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv); $bits{$_}{5} = 'OPpHUSH_VMSISH' for qw(dbstate nextstate); +$bits{$_}{6} = 'OPpINDEX_BOOLNEG' for qw(index rindex); $bits{$_}{1} = '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{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multiconcat multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv split); $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 rv2av rv2gv rv2hv substr vec); -$bits{$_}{4} = 'OPpMAYBE_TRUEBOOL' for qw(padhv rv2hv); +$bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr values vec); +$bits{$_}{4} = 'OPpMAYBE_TRUEBOOL' for qw(padhv ref 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); @@ -147,9 +148,8 @@ $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 mkdir modulo multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid); +$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 mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time 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); @@ -157,7 +157,7 @@ $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); +$bits{$_}{5} = 'OPpTRUEBOOL' for qw(grepwhile index length padav padhv pos ref rindex rv2av rv2hv subst); my @bf = ( { @@ -175,6 +175,13 @@ my @bf = ( bitmask => 3, }, { + label => 'offset', + mask_def => 'OPpAVHVSWITCH_MASK', + bitmin => 0, + bitmax => 1, + bitmask => 3, + }, + { label => '-', mask_def => 'OPpARG3_MASK', bitmin => 0, @@ -189,7 +196,7 @@ my @bf = ( bitmask => 15, }, { - label => '-', + label => 'range', mask_def => 'OPpPADRANGE_COUNTMASK', bitcount_def => 'OPpPADRANGE_COUNTSHIFT', bitmin => 0, @@ -197,12 +204,23 @@ my @bf = ( bitmask => 127, }, { - label => '-', + label => 'key', bitmin => 0, bitmax => 7, bitmask => 255, }, { + mask_def => 'OPpARGELEM_MASK', + bitmin => 1, + bitmax => 2, + bitmask => 6, + enum => [ + 0, 'OPpARGELEM_SV', 'SV', + 1, 'OPpARGELEM_AV', 'AV', + 2, 'OPpARGELEM_HV', 'HV', + ], + }, + { mask_def => 'OPpDEREF', bitmin => 4, bitmax => 5, @@ -227,54 +245,58 @@ my @bf = ( }, ); -@{$bits{aassign}}{6,5,4,1,0} = ('OPpASSIGN_COMMON_SCALAR', 'OPpASSIGN_COMMON_RC1', 'OPpASSIGN_COMMON_AGG', $bf[1], $bf[1]); +@{$bits{aassign}}{6,5,4,2,1,0} = ('OPpASSIGN_COMMON_SCALAR', 'OPpASSIGN_COMMON_RC1', 'OPpASSIGN_COMMON_AGG', 'OPpASSIGN_TRUEBOOL', $bf[1], $bf[1]); $bits{abs}{0} = $bf[0]; -@{$bits{accept}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{accept}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$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{aelem}}{5,4,1,0} = ($bf[8], $bf[8], $bf[1], $bf[1]); +@{$bits{aelemfast}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]); +@{$bits{aelemfast_lex}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]); $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{anonhash}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{anonlist}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{argcheck}{0} = $bf[0]; +$bits{argdefelem}{0} = $bf[0]; +@{$bits{argelem}}{2,1,0} = ($bf[7], $bf[7], $bf[0]); +@{$bits{atan2}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{av2arylen}{0} = $bf[0]; $bits{avalues}{0} = $bf[0]; +@{$bits{avhvswitch}}{1,0} = ($bf[2], $bf[2]); $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{bind}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{binmode}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$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{bless}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{caller}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{chdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{chmod}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{chown}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{close}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{closedir}{0} = $bf[0]; $bits{complement}{0} = $bf[0]; -@{$bits{concat}}{1,0} = ($bf[1], $bf[1]); +@{$bits{concat}}{6,1,0} = ('OPpCONCAT_NESTED', $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{connect}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$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{crypt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{dbmclose}{0} = $bf[0]; -@{$bits{dbmopen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{dbmopen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{delete}}{6,5,0} = ('OPpSLICE', 'OPpKVSLICE', $bf[0]); +@{$bits{die}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$bits{divide}}{1,0} = ($bf[1], $bf[1]); $bits{dofile}{0} = $bf[0]; $bits{dor}{0} = $bf[0]; @@ -284,23 +306,23 @@ $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{entersub}}{5,4,0} = ($bf[8], $bf[8], '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{enterwrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{eof}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$bits{eq}}{1,0} = ($bf[1], $bf[1]); -@{$bits{exec}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{exec}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$bits{exists}}{6,0} = ('OPpEXISTS_SUB', $bf[0]); -@{$bits{exit}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{exit}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{fcntl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{fileno}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{flip}{0} = $bf[0]; -@{$bits{flock}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{flock}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{flop}{0} = $bf[0]; -@{$bits{formline}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{formline}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{ftatime}{0} = $bf[0]; $bits{ftbinary}{0} = $bf[0]; $bits{ftblk}{0} = $bf[0]; @@ -330,32 +352,32 @@ $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{getc}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{getpgrp}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{getpriority}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{ghbyaddr}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{glob}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{gmtime}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{gnbyaddr}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{gpbynumber}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{gsbyname}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{gsbyport}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{gsockopt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$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{helem}}{5,4,1,0} = ($bf[8], $bf[8], $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]); @@ -374,12 +396,12 @@ $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{index}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{ioctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{join}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{keys}{0} = $bf[0]; -@{$bits{kill}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{kill}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{last}{0} = $bf[0]; $bits{lc}{0} = $bf[0]; $bits{lcfirst}{0} = $bf[0]; @@ -393,9 +415,9 @@ $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{link}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{list}{6} = 'OPpLIST_GUESSED'; -@{$bits{listen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{listen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{localtime}{0} = $bf[0]; $bits{lock}{0} = $bf[0]; $bits{log}{0} = $bf[0]; @@ -403,7 +425,7 @@ $bits{log}{0} = $bf[0]; $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{lvref}}{5,4,0} = ($bf[9], $bf[9], $bf[0]); $bits{mapstart}{0} = $bf[0]; $bits{mapwhile}{0} = $bf[0]; $bits{method}{0} = $bf[0]; @@ -411,12 +433,13 @@ $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{mkdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$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{msgctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{msgget}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{msgrcv}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{msgsnd}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{multiconcat}}{6,5,3,0} = ('OPpMULTICONCAT_APPEND', 'OPpMULTICONCAT_FAKE', 'OPpMULTICONCAT_STRINGIFY', $bf[0]); @{$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]); @@ -430,15 +453,16 @@ $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{open}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{open_dir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{pack}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{padhv}{0} = 'OPpPADHV_ISKEYS'; +@{$bits{padrange}}{6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]); +@{$bits{padsv}}{5,4} = ($bf[8], $bf[8]); +@{$bits{pipe_op}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{pop}{0} = $bf[0]; $bits{pos}{0} = $bf[0]; $bits{postdec}{0} = $bf[0]; @@ -447,36 +471,36 @@ $bits{postinc}{0} = $bf[0]; $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{push}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{quotemeta}{0} = $bf[0]; -@{$bits{rand}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{rand}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{range}{0} = $bf[0]; -@{$bits{read}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{read}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{recv}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{refassign}}{5,4,1,0} = ($bf[9], $bf[9], $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{rename}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$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{reset}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$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{rindex}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{rv2gv}}{6,5,4,2,0} = ('OPpALLOW_FAKE', $bf[8], $bf[8], 'OPpDONT_INIT_GV', $bf[0]); +$bits{rv2hv}{0} = 'OPpRV2HV_ISKEYS'; +@{$bits{rv2sv}}{5,4,0} = ($bf[8], $bf[8], $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]); @@ -486,76 +510,76 @@ $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{seek}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{seekdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{select}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{semctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{semget}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{semop}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{send}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$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{setpgrp}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{setpriority}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$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{shmctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{shmget}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{shmread}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{shmwrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{shostent}{0} = $bf[0]; -@{$bits{shutdown}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{shutdown}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{sleep}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$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{socket}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{sockpair}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{sort}}{7,6,4,3,2,1,0} = ('OPpSORT_UNSTABLE', 'OPpSORT_STABLE', 'OPpSORT_DESCEND', 'OPpSORT_INPLACE', 'OPpSORT_REVERSE', 'OPpSORT_INTEGER', 'OPpSORT_NUMERIC'); +@{$bits{splice}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{split}}{4,3,2} = ('OPpSPLIT_ASSIGN', 'OPpSPLIT_LEX', 'OPpSPLIT_IMPLIM'); +@{$bits{sprintf}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{srand}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{srefgen}{0} = $bf[0]; -@{$bits{sselect}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{sselect}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{sservent}{0} = $bf[0]; -@{$bits{ssockopt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{ssockopt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{stat}{0} = $bf[0]; -@{$bits{stringify}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{stringify}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{substr}}{4,2,1,0} = ('OPpSUBSTR_REPL_FIRST', $bf[3], $bf[3], $bf[3]); @{$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{symlink}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{syscall}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{sysopen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{sysread}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{sysseek}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{system}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{syswrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{tell}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{telldir}{0} = $bf[0]; -@{$bits{tie}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{tie}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{tied}{0} = $bf[0]; -@{$bits{truncate}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{truncate}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{umask}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{unlink}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{unpack}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{unshift}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{untie}{0} = $bf[0]; -@{$bits{utime}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{utime}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $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{waitpid}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{warn}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$bits{xor}}{1,0} = ($bf[1], $bf[1]); @@ -565,11 +589,18 @@ our %defines = ( OPpARG2_MASK => 3, OPpARG3_MASK => 7, OPpARG4_MASK => 15, + OPpARGELEM_AV => 2, + OPpARGELEM_HV => 4, + OPpARGELEM_MASK => 6, + OPpARGELEM_SV => 0, OPpASSIGN_BACKWARDS => 64, OPpASSIGN_COMMON_AGG => 16, OPpASSIGN_COMMON_RC1 => 32, OPpASSIGN_COMMON_SCALAR => 64, OPpASSIGN_CV_TO_GV => 128, + OPpASSIGN_TRUEBOOL => 4, + OPpAVHVSWITCH_MASK => 3, + OPpCONCAT_NESTED => 64, OPpCONST_BARE => 64, OPpCONST_ENTERED => 16, OPpCONST_NOVER => 2, @@ -603,8 +634,10 @@ our %defines = ( OPpFT_STACKING => 8, OPpHINT_STRICT_REFS => 2, OPpHUSH_VMSISH => 32, + OPpINDEX_BOOLNEG => 64, OPpITER_DEF => 8, OPpITER_REVERSED => 2, + OPpKVSLICE => 32, OPpLIST_GUESSED => 64, OPpLVALUE => 128, OPpLVAL_DEFER => 64, @@ -619,6 +652,9 @@ our %defines = ( OPpMAYBE_LVSUB => 8, OPpMAYBE_TRUEBOOL => 16, OPpMAY_RETURN_CONSTANT => 32, + OPpMULTICONCAT_APPEND => 64, + OPpMULTICONCAT_FAKE => 32, + OPpMULTICONCAT_STRINGIFY => 8, OPpMULTIDEREF_DELETE => 32, OPpMULTIDEREF_EXISTS => 16, OPpOFFBYONE => 128, @@ -627,6 +663,7 @@ our %defines = ( OPpOPEN_OUT_CRLF => 128, OPpOPEN_OUT_RAW => 64, OPpOUR_INTRO => 64, + OPpPADHV_ISKEYS => 1, OPpPADRANGE_COUNTMASK => 127, OPpPADRANGE_COUNTSHIFT => 7, OPpPAD_STATE => 64, @@ -634,17 +671,19 @@ our %defines = ( OPpREFCOUNTED => 64, OPpREPEAT_DOLIST => 64, OPpREVERSE_INPLACE => 8, - OPpRUNTIME => 64, + OPpRV2HV_ISKEYS => 1, 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, + OPpSORT_UNSTABLE => 128, + OPpSPLIT_ASSIGN => 16, + OPpSPLIT_IMPLIM => 4, + OPpSPLIT_LEX => 8, OPpSUBSTR_REPL_FIRST => 16, OPpTARGET_MY => 16, OPpTRANS_COMPLEMENT => 32, @@ -659,11 +698,16 @@ our %defines = ( our %labels = ( OPpALLOW_FAKE => 'FAKE', + OPpARGELEM_AV => 'AV', + OPpARGELEM_HV => 'HV', + OPpARGELEM_SV => 'SV', OPpASSIGN_BACKWARDS => 'BKWARD', OPpASSIGN_COMMON_AGG => 'COM_AGG', OPpASSIGN_COMMON_RC1 => 'COM_RC1', OPpASSIGN_COMMON_SCALAR => 'COM_SCALAR', OPpASSIGN_CV_TO_GV => 'CV2GV', + OPpASSIGN_TRUEBOOL => 'BOOL', + OPpCONCAT_NESTED => 'NESTED', OPpCONST_BARE => 'BARE', OPpCONST_ENTERED => 'ENTERED', OPpCONST_NOVER => 'NOVER', @@ -696,8 +740,10 @@ our %labels = ( OPpFT_STACKING => 'FTSTACKING', OPpHINT_STRICT_REFS => 'STRICT', OPpHUSH_VMSISH => 'HUSH', + OPpINDEX_BOOLNEG => 'NEG', OPpITER_DEF => 'DEF', OPpITER_REVERSED => 'REVERSED', + OPpKVSLICE => 'KVSLICE', OPpLIST_GUESSED => 'GUESSED', OPpLVALUE => 'LV', OPpLVAL_DEFER => 'LVDEFER', @@ -711,6 +757,9 @@ our %labels = ( OPpMAYBE_LVSUB => 'LVSUB', OPpMAYBE_TRUEBOOL => 'BOOL?', OPpMAY_RETURN_CONSTANT => 'CONST', + OPpMULTICONCAT_APPEND => 'APPEND', + OPpMULTICONCAT_FAKE => 'FAKE', + OPpMULTICONCAT_STRINGIFY => 'STRINGIFY', OPpMULTIDEREF_DELETE => 'DELETE', OPpMULTIDEREF_EXISTS => 'EXISTS', OPpOFFBYONE => '+1', @@ -719,22 +768,25 @@ our %labels = ( OPpOPEN_OUT_CRLF => 'OUTCR', OPpOPEN_OUT_RAW => 'OUTBIN', OPpOUR_INTRO => 'OURINTR', + OPpPADHV_ISKEYS => 'KEYS', OPpPAD_STATE => 'STATE', OPpPV_IS_UTF8 => 'UTF', OPpREFCOUNTED => 'REFC', OPpREPEAT_DOLIST => 'DOLIST', OPpREVERSE_INPLACE => 'INPLACE', - OPpRUNTIME => 'RTIME', + OPpRV2HV_ISKEYS => 'KEYS', 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', + OPpSORT_UNSTABLE => 'UNSTABLE', + OPpSPLIT_ASSIGN => 'ASSIGN', OPpSPLIT_IMPLIM => 'IMPLIM', + OPpSPLIT_LEX => 'LEX', OPpSUBSTR_REPL_FIRST => 'REPL1ST', OPpTARGET_MY => 'TARGMY', OPpTRANS_COMPLEMENT => 'COMPL', @@ -752,6 +804,7 @@ our %ops_using = ( OPpALLOW_FAKE => [qw(rv2gv)], OPpASSIGN_BACKWARDS => [qw(sassign)], OPpASSIGN_COMMON_AGG => [qw(aassign)], + OPpCONCAT_NESTED => [qw(concat)], OPpCONST_BARE => [qw(const)], OPpCOREARGS_DEREF1 => [qw(coreargs)], OPpEARLY_CV => [qw(gv)], @@ -765,37 +818,42 @@ our %ops_using = ( 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)], OPpHINT_STRICT_REFS => [qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv)], OPpHUSH_VMSISH => [qw(dbstate nextstate)], + OPpINDEX_BOOLNEG => [qw(index rindex)], OPpITER_DEF => [qw(enteriter)], OPpITER_REVERSED => [qw(enteriter iter)], + OPpKVSLICE => [qw(delete)], 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)], + OPpLVAL_INTRO => [qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multiconcat multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv split)], OPpLVREF_ELEM => [qw(lvref refassign)], - OPpMAYBE_LVSUB => [qw(aassign aelem aslice av2arylen helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr vec)], - OPpMAYBE_TRUEBOOL => [qw(padhv rv2hv)], + OPpMAYBE_LVSUB => [qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr values vec)], + OPpMAYBE_TRUEBOOL => [qw(padhv ref rv2hv)], + OPpMULTICONCAT_APPEND => [qw(multiconcat)], OPpMULTIDEREF_DELETE => [qw(multideref)], OPpOFFBYONE => [qw(caller runcv wantarray)], OPpOPEN_IN_CRLF => [qw(backtick open)], OPpOUR_INTRO => [qw(enteriter gvsv rv2av rv2hv rv2sv split)], + OPpPADHV_ISKEYS => [qw(padhv)], 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)], + OPpRV2HV_ISKEYS => [qw(rv2hv)], OPpSLICEWARNING => [qw(aslice hslice padav padhv rv2av rv2hv)], OPpSORT_DESCEND => [qw(sort)], - OPpSPLIT_IMPLIM => [qw(split)], + OPpSPLIT_ASSIGN => [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 mkdir modulo multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid)], + 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 mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid)], OPpTRANS_COMPLEMENT => [qw(trans transr)], + OPpTRUEBOOL => [qw(grepwhile index length padav padhv pos ref rindex rv2av rv2hv subst)], ); $ops_using{OPpASSIGN_COMMON_RC1} = $ops_using{OPpASSIGN_COMMON_AGG}; $ops_using{OPpASSIGN_COMMON_SCALAR} = $ops_using{OPpASSIGN_COMMON_AGG}; $ops_using{OPpASSIGN_CV_TO_GV} = $ops_using{OPpASSIGN_BACKWARDS}; +$ops_using{OPpASSIGN_TRUEBOOL} = $ops_using{OPpASSIGN_COMMON_AGG}; $ops_using{OPpCONST_ENTERED} = $ops_using{OPpCONST_BARE}; $ops_using{OPpCONST_NOVER} = $ops_using{OPpCONST_BARE}; $ops_using{OPpCONST_SHORTCIRCUIT} = $ops_using{OPpCONST_BARE}; @@ -814,22 +872,26 @@ $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{OPpMULTICONCAT_FAKE} = $ops_using{OPpMULTICONCAT_APPEND}; +$ops_using{OPpMULTICONCAT_STRINGIFY} = $ops_using{OPpMULTICONCAT_APPEND}; $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{OPpSLICE} = $ops_using{OPpKVSLICE}; $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{OPpSORT_UNSTABLE} = $ops_using{OPpSORT_DESCEND}; +$ops_using{OPpSPLIT_IMPLIM} = $ops_using{OPpSPLIT_ASSIGN}; +$ops_using{OPpSPLIT_LEX} = $ops_using{OPpSPLIT_ASSIGN}; $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: |