?????????? ????????? - ??????????????? - /home/agenciai/public_html/cd38d8/B.tar
???????
Deparse.pm 0000644 00000632444 15125173167 0006512 0 ustar 00 # B::Deparse.pm # Copyright (c) 1998-2000, 2002, 2003, 2004, 2005, 2006 Stephen McCamant. # All rights reserved. # This module is free software; you can redistribute and/or modify # it under the same terms as Perl itself. # This is based on the module of the same name by Malcolm Beattie, # but essentially none of his code remains. package B::Deparse; use Carp; use B qw(class main_root main_start main_cv svref_2object opnumber perlstring OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPf_PARENS 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 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED PMf_EXTENDED_MORE PADNAMEt_OUTER MDEREF_reload MDEREF_AV_pop_rv2av_aelem MDEREF_AV_gvsv_vivify_rv2av_aelem MDEREF_AV_padsv_vivify_rv2av_aelem MDEREF_AV_vivify_rv2av_aelem MDEREF_AV_padav_aelem MDEREF_AV_gvav_aelem MDEREF_HV_pop_rv2hv_helem MDEREF_HV_gvsv_vivify_rv2hv_helem MDEREF_HV_padsv_vivify_rv2hv_helem MDEREF_HV_vivify_rv2hv_helem MDEREF_HV_padhv_helem MDEREF_HV_gvhv_helem MDEREF_ACTION_MASK MDEREF_INDEX_none MDEREF_INDEX_const MDEREF_INDEX_padsv MDEREF_INDEX_gvsv MDEREF_INDEX_MASK MDEREF_FLAG_last MDEREF_MASK MDEREF_SHIFT ); $VERSION = '1.54'; use strict; 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 # be to fake up a dummy constant that will never actually be true. foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE PMf_CHARSET PMf_KEEPCOPY PMf_NOCAPTURE CVf_ANONCONST CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST PMf_NONDESTRUCT OPpEVAL_BYTES OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV OPpLVREF_CV OPpLVREF_ELEM SVpad_STATE)) { eval { B->import($_) }; no strict 'refs'; *{$_} = sub () {0} unless *{$_}{CODE}; } } # Todo: # (See also BUGS section at the end of this file) # # - finish tr/// changes # - add option for even more parens (generalize \&foo change) # - left/right context # - copy comments (look at real text with $^P?) # - avoid semis in one-statement blocks # - associativity of &&=, ||=, ?: # - ',' => '=>' (auto-unquote?) # - break long lines ("\r" as discretionary break?) # - configurable syntax highlighting: ANSI color, HTML, TeX, etc. # - more style options: brace style, hex vs. octal, quotes, ... # - print big ints as hex/octal instead of decimal (heuristic?) # - handle 'my $x if 0'? # - version using op_next instead of op_first/sibling? # - avoid string copies (pass arrays, one big join?) # - here-docs? # Current test.deparse failures # comp/hints 6 - location of BEGIN blocks wrt. block openings # run/switchI 1 - missing -I switches entirely # perl -Ifoo -e 'print @INC' # op/caller 2 - warning mask propagates backwards before warnings::register # 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register' # op/getpid 2 - can't assign to shared my() declaration (threads only) # 'my $x : shared = 5' # op/override 7 - parens on overridden require change v-string interpretation # 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6' # c.f. 'BEGIN { *f = sub {0} }; f 2' # op/pat 774 - losing Unicode-ness of Latin1-only strings # 'use charnames ":short"; $x="\N{latin:a with acute}"' # op/recurse 12 - missing parens on recursive call makes it look like method # 'sub f { f($x) }' # op/subst 90 - inconsistent handling of utf8 under "use utf8" # op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open # op/tiehandle compile - "use strict" deparsed in the wrong place # uni/tr_ several # ext/B/t/xref 11 - line numbers when we add newlines to one-line subs # ext/Data/Dumper/t/dumper compile # ext/DB_file/several # ext/Encode/several # ext/Ernno/Errno warnings # ext/IO/lib/IO/t/io_sel 23 # ext/PerlIO/t/encoding compile # ext/POSIX/t/posix 6 # ext/Socket/Socket 8 # ext/Storable/t/croak compile # lib/Attribute/Handlers/t/multi compile # lib/bignum/ several # lib/charnames 35 # lib/constant 32 # lib/English 40 # lib/ExtUtils/t/bytes 4 # lib/File/DosGlob compile # lib/Filter/Simple/t/data 1 # lib/Math/BigInt/t/constant 1 # lib/Net/t/config Deparse-warning # lib/overload compile # lib/Switch/ several # lib/Symbol 4 # lib/Test/Simple several # lib/Term/Complete # lib/Tie/File/t/29_downcopy 5 # lib/vars 22 # Object fields: # # in_coderef2text: # True when deparsing via $deparse->coderef2text; false when deparsing the # main program. # # avoid_local: # (local($a), local($b)) and local($a, $b) have the same internal # representation but the short form looks better. We notice we can # use a large-scale local when checking the list, but need to prevent # individual locals too. This hash holds the addresses of OPs that # have already had their local-ness accounted for. The same thing # is done with my(). # # curcv: # CV for current sub (or main program) being deparsed # # curcvlex: # Cached hash of lexical variables for curcv: keys are # names prefixed with "m" or "o" (representing my/our), and # each value is an array with two elements indicating the cop_seq # of scopes in which a var of that name is valid and a third ele- # ment referencing the pad name. # # curcop: # COP for statement being deparsed # # curstash: # name of the current package for deparsed code # # subs_todo: # array of [cop_seq, CV, is_format?, name] for subs and formats we still # want to deparse. The fourth element is a pad name thingy for lexical # subs or a string for special blocks. For other subs, it is undef. For # lexical subs, CV may be undef, indicating a stub declaration. # # protos_todo: # as above, but [name, prototype] for subs that never got a GV # # subs_done, forms_done: # keys are addresses of GVs for subs and formats we've already # deparsed (or at least put into subs_todo) # # subs_declared # keys are names of subs for which we've printed declarations. # That means we can omit parentheses from the arguments. It also means we # need to put CORE:: on core functions of the same name. # # in_subst_repl # True when deparsing the replacement part of a substitution. # # in_refgen # True when deparsing the argument to \. # # parens: -p # linenums: -l # unquote: -q # cuddle: ' ' or '\n', depending on -sC # indent_size: -si # use_tabs: -sT # ex_const: -sv # A little explanation of how precedence contexts and associativity # work: # # deparse() calls each per-op subroutine with an argument $cx (short # for context, but not the same as the cx* in the perl core), which is # a number describing the op's parents in terms of precedence, whether # they're inside an expression or at statement level, etc. (see # chart below). When ops with children call deparse on them, they pass # along their precedence. Fractional values are used to implement # associativity ('($x + $y) + $z' => '$x + $y + $y') and related # parentheses hacks. The major disadvantage of this scheme is that # it doesn't know about right sides and left sides, so say if you # assign a listop to a variable, it can't tell it's allowed to leave # the parens off the listop. # Precedences: # 26 [TODO] inside interpolation context ("") # 25 left terms and list operators (leftward) # 24 left -> # 23 nonassoc ++ -- # 22 right ** # 21 right ! ~ \ and unary + and - # 20 left =~ !~ # 19 left * / % x # 18 left + - . # 17 left << >> # 16 nonassoc named unary operators # 15 nonassoc < > <= >= lt gt le ge # 14 nonassoc == != <=> eq ne cmp # 13 left & # 12 left | ^ # 11 left && # 10 left || # 9 nonassoc .. ... # 8 right ?: # 7 right = += -= *= etc. # 6 left , => # 5 nonassoc list operators (rightward) # 4 right not # 3 left and # 2 left or xor # 1 statement modifiers # 0.5 statements, but still print scopes as do { ... } # 0 statement level # -1 format body # Nonprinting characters with special meaning: # \cS - steal parens (see maybe_parens_unop) # \n - newline and indent # \t - increase indent # \b - decrease indent ('outdent') # \f - flush left (no indent) # \cK - kill following semicolon, if any # Semicolon handling: # - Individual statements are not deparsed with trailing semicolons. # (If necessary, \cK is tacked on to the end.) # - Whatever code joins statements together or emits them (lineseq, # scopeop, deparse_root) is responsible for adding semicolons where # necessary. # - use statements are deparsed with trailing semicolons because they are # immediately concatenated with the following statement. # - indent() removes semicolons wherever it sees \cK. BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem kvaslice kvhslice padsv argcheck nextstate dbstate rv2av rv2hv helem custom ]) { eval "sub OP_\U$_ () { " . opnumber($_) . "}" }} # _pessimise_walk(): recursively walk the optree of a sub, # possibly undoing optimisations along the way. sub DEBUG { 0 } sub _pessimise_walk { my ($self, $startop) = @_; return unless $$startop; my ($op, $prevop); for ($op = $startop; $$op; $prevop = $op, $op = $op->sibling) { my $ppname = $op->name; # pessimisations start here if ($ppname eq "padrange") { # remove PADRANGE: # the original optimisation either (1) changed this: # pushmark -> (various pad and list and null ops) -> the_rest # or (2), for the = @_ case, changed this: # pushmark -> gv[_] -> rv2av -> (pad stuff) -> the_rest # into this: # padrange ----------------------------------------> the_rest # so we just need to convert the padrange back into a # pushmark, and in case (1), set its op_next to op_sibling, # which is the head of the original chain of optimised-away # pad ops, or for (2), set it to sibling->first, which is # the original gv[_]. $B::overlay->{$$op} = { type => OP_PUSHMARK, name => 'pushmark', private => ($op->private & OPpLVAL_INTRO), }; } # pessimisations end here 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); } } } # _pessimise_walk_exe(): recursively walk the op_next chain of a sub, # possibly undoing optimisations along the way. sub _pessimise_walk_exe { my ($self, $startop, $visited) = @_; no warnings 'recursion'; return unless $$startop; return if $visited->{$$startop}; my ($op, $prevop); for ($op = $startop; $$op; $prevop = $op, $op = $op->next) { last if $visited->{$$op}; $visited->{$$op} = 1; my $ppname = $op->name; if ($ppname =~ /^((and|d?or)(assign)?|(map|grep)while|range|cond_expr|once)$/ # entertry is also a logop, but its op_other invariably points # into the same chain as the main execution path, so we skip it ) { $self->_pessimise_walk_exe($op->other, $visited); } elsif ($ppname eq "subst") { $self->_pessimise_walk_exe($op->pmreplstart, $visited); } elsif ($ppname =~ /^(enter(loop|iter))$/) { # redoop and nextop will already be covered by the main block # of the loop $self->_pessimise_walk_exe($op->lastop, $visited); } # pessimisations start here } } # Go through an optree and "remove" some optimisations by using an # overlay to selectively modify or un-null some ops. Deparsing in the # absence of those optimisations is then easier. # # Note that older optimisations are not removed, as Deparse was already # written to recognise them before the pessimise/overlay system was added. sub pessimise { my ($self, $root, $start) = @_; no warnings 'recursion'; # walk tree in root-to-branch order $self->_pessimise_walk($root); my %visited; # walk tree in execution order $self->_pessimise_walk_exe($start, \%visited); } sub null { my $op = shift; 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) = @_; my $cvfile = $cv->FILE//''; return unless ($cvfile eq $0 || exists $self->{files}{$cvfile}); my $seq; if ($cv->OUTSIDE_SEQ) { $seq = $cv->OUTSIDE_SEQ; } elsif (!null($cv->START) and is_state($cv->START)) { $seq = $cv->START->cop_seq; } 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 ($seq, $cv, $is_form, $name) = @$ent; # 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); } if (ref $name) { # lexical sub # emit the sub. my @text; my $flags = $name->FLAGS; push @text, !$cv || $seq <= $name->COP_SEQ_RANGE_LOW ? $self->keyword($flags & SVpad_OUR ? "our" : $flags & SVpad_STATE ? "state" : "my") . " " : ""; # XXX We would do $self->keyword("sub"), but ‘my CORE::sub’ # doesn’t work and ‘my sub’ ignores a &sub in scope. I.e., # we have a core bug here. push @text, "sub " . substr $name->PVX, 1; if ($cv) { # my sub foo { } push @text, " " . $self->deparse_sub($cv); $text[-1] =~ s/ ;$/;/; } else { # my sub foo; push @text, ";\n"; } return $pragmata . join "", @text; } my $gv = $cv->GV; $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 $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; } } my $l = ''; if ($self->{'linenums'}) { my $line = $gv->LINE; my $file = $gv->FILE; $l = "\n\f#line $line \"$file\"\n"; } my $p = ''; my $stash; if (class($cv->STASH) ne "SPECIAL") { $stash = $cv->STASH->NAME; if ($stash ne $self->{'curstash'}) { $p = $self->keyword("package") . " $stash;\n"; $name = "$self->{'curstash'}::$name" unless $name =~ /::/; $self->{'curstash'} = $stash; } } if ($use_dec) { return "$pragmata$p$l$use_dec"; } if ( $name !~ /::/ and $self->lex_in_scope("&$name") || $self->lex_in_scope("&$name", 1) ) { $name = "$self->{'curstash'}::$name"; } elsif (defined $stash) { $name =~ s/^\Q$stash\E::(?!\z|.*::)//; } my $ret = "$pragmata${p}${l}" . $self->keyword("sub") . " $name " . $self->deparse_sub($cv); $self->{'subs_declared'}{$name} = 1; return $ret; } } # Return a "use" declaration for this BEGIN block, if appropriate sub begin_is_use { my ($self, $cv) = @_; my $root = $cv->ROOT; local @$self{qw'curcv curcvlex'} = ($cv); local $B::overlay = {}; $self->pessimise($root, $cv->START); #require B::Debug; #B::walkoptree($cv->ROOT, "debug"); my $lineseq = $root->first; return if $lineseq->name ne "lineseq"; 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 $module = $self->const_sv($req_op->first)->PV; $module =~ s[/][::]g; $module =~ s/.pm$//; } else { $module = $self->const($self->const_sv($req_op->first), 6); } my $version; my $version_op = $req_op->sibling; return if class($version_op) eq "NULL"; if ($version_op->name eq "lineseq") { # We have a version parameter; skip nextstate & pushmark my $constop = $version_op->first->next->next; return unless $self->const_sv($constop)->PV eq $module; $constop = $constop->sibling; $version = $self->const_sv($constop); if (class($version) eq "IV") { $version = $version->int_value; } elsif (class($version) eq "NV") { $version = $version->NV; } elsif (class($version) ne "PVMG") { # Includes PVIV and PVNV $version = $version->PV; } else { # version specified as a v-string $version = 'v'.join '.', map ord, split //, $version->PV; } $constop = $constop->sibling; return if $constop->name ne "method_named"; return if $self->meth_sv($constop)->PV ne "VERSION"; } $lineseq = $version_op->sibling; return if $lineseq->name ne "lineseq"; my $entersub = $lineseq->first->sibling; if ($entersub->name eq "stub") { return "use $module $version ();\n" if defined $version; return "use $module ();\n"; } return if $entersub->name ne "entersub"; # See if there are import arguments my $args = ''; my $svop = $entersub->first->sibling; # Skip over pushmark return unless $self->const_sv($svop)->PV eq $module; # Pull out the arguments for ($svop=$svop->sibling; index($svop->name, "method_") != 0; $svop = $svop->sibling) { $args .= ", " if length($args); $args .= $self->deparse($svop, 6); } my $use = 'use'; my $method_named = $svop; return if $method_named->name ne "method_named"; my $method_name = $self->meth_sv($method_named)->PV; if ($method_name eq "unimport") { $use = 'no'; } # Certain pragmas are dealt with using hint bits, # so we ignore them here if ($module eq 'strict' || $module eq 'integer' || $module eq 'bytes' || $module eq 'warnings' || $module eq 'feature') { return ""; } if (defined $version && length $args) { return "$use $module $version ($args);\n"; } elsif (defined $version) { return "$use $module $version;\n"; } elsif (length $args) { return "$use $module ($args);\n"; } else { return "$use $module;\n"; } } sub stash_subs { my ($self, $pack, $seen) = @_; my (@ret, $stash); if (!defined $pack) { $pack = ''; $stash = \%::; } else { $pack =~ s/(::)?$/::/; no strict 'refs'; $stash = \%{"main::$pack"}; } return if ($seen ||= {})->{ $INC{"overload.pm"} ? overload::StrVal($stash) : $stash }++; my $stashobj = svref_2object($stash); my %stash = $stashobj->ARRAY; while (my ($key, $val) = each %stash) { my $flags = $val->FLAGS; if ($flags & SVf_ROK) { # A reference. Dump this if it is a reference to a CV. If it # is a constant acting as a proxy for a full subroutine, then # we may or may not have to dump it. If some form of perl- # space visible code must have created it, be it a use # statement, or some direct symbol-table manipulation code that # we will deparse, then we don’t want to dump it. If it is the # result of a declaration like sub f () { 42 } then we *do* # want to dump it. The only way to distinguish these seems # to be the SVs_PADTMP flag on the constant, which is admit- # tedly a hack. my $class = class(my $referent = $val->RV); if ($class eq "CV") { $self->todo($referent, 0); } elsif ( $class !~ /^(AV|HV|CV|FM|IO|SPECIAL)\z/ # A more robust way to write that would be this, but B does # not provide the SVt_ constants: # ($referent->FLAGS & B::SVTYPEMASK) < B::SVt_PVAV and $referent->FLAGS & SVs_PADTMP ) { push @{$self->{'protos_todo'}}, [$pack . $key, $val]; } } elsif ($flags & (SVf_POK|SVf_IOK)) { # Just a prototype. As an ugly but fairly effective way # to find out if it belongs here is to see if the AUTOLOAD # (if any) for the stash was defined in one of our files. my $A = $stash{"AUTOLOAD"}; if (defined ($A) && class($A) eq "GV" && defined($A->CV) && class($A->CV) eq "CV") { my $AF = $A->FILE; next unless $AF eq $0 || exists $self->{'files'}{$AF}; } push @{$self->{'protos_todo'}}, [$pack . $key, $flags & SVf_POK ? $val->PV: undef]; } elsif (class($val) eq "GV") { if (class(my $cv = $val->CV) ne "SPECIAL") { next if $self->{'subs_done'}{$$val}++; # 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") { next if $self->{'forms_done'}{$$val}++; next if $$val != ${$cv->GV}; # Ignore imposters $self->todo($cv, 1); } if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) { $self->stash_subs($pack . $key, $seen); } } } } sub print_protos { my $self = shift; 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}" : " (". $ar->[1] . ");" : ";"; push @ret, "sub " . $ar->[0] . "$body\n"; } delete $self->{'protos_todo'}; return @ret; } sub style_opts { my $self = shift; my $opts = shift; my $opt; while (length($opt = substr($opts, 0, 1))) { if ($opt eq "C") { $self->{'cuddle'} = " "; $opts = substr($opts, 1); } elsif ($opt eq "i") { $opts =~ s/^i(\d+)//; $self->{'indent_size'} = $1; } elsif ($opt eq "T") { $self->{'use_tabs'} = 1; $opts = substr($opts, 1); } elsif ($opt eq "v") { $opts =~ s/^v([^.]*)(.|$)//; $self->{'ex_const'} = $1; } } } sub new { my $class = shift; my $self = bless {}, $class; $self->{'cuddle'} = "\n"; $self->{'curcop'} = undef; $self->{'curstash'} = "main"; $self->{'ex_const'} = "'???'"; $self->{'expand'} = 0; $self->{'files'} = {}; $self->{'packs'} = {}; $self->{'indent_size'} = 4; $self->{'linenums'} = 0; $self->{'parens'} = 0; $self->{'subs_todo'} = []; $self->{'unquote'} = 0; $self->{'use_dumper'} = 0; $self->{'use_tabs'} = 0; $self->{'ambient_warnings'} = undef; # Assume no lexical warnings $self->{'ambient_hints'} = 0; $self->{'ambient_hinthash'} = undef; $self->init(); while (my $arg = shift @_) { if ($arg eq "-d") { $self->{'use_dumper'} = 1; require Data::Dumper; } elsif ($arg =~ /^-f(.*)/) { $self->{'files'}{$1} = 1; } elsif ($arg eq "-l") { $self->{'linenums'} = 1; } elsif ($arg eq "-p") { $self->{'parens'} = 1; } elsif ($arg eq "-P") { $self->{'noproto'} = 1; } elsif ($arg eq "-q") { $self->{'unquote'} = 1; } elsif (substr($arg, 0, 2) eq "-s") { $self->style_opts(substr $arg, 2); } elsif ($arg =~ /^-x(\d)$/) { $self->{'expand'} = $1; } } return $self; } { # Mask out the bits that L<warnings::register> uses my $WARN_MASK; BEGIN { $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all}; } sub WARN_MASK () { return $WARN_MASK; } } # Initialise the contextual information, either from # defaults provided with the ambient_pragmas method, # or from perl's own defaults otherwise. sub init { my $self = shift; $self->{'warnings'} = defined ($self->{'ambient_warnings'}) ? $self->{'ambient_warnings'} & WARN_MASK : undef; $self->{'hints'} = $self->{'ambient_hints'}; $self->{'hinthash'} = $self->{'ambient_hinthash'}; # also a convenient place to clear out subs_declared delete $self->{'subs_declared'}; } sub compile { my(@args) = @_; return sub { my $self = B::Deparse->new(@args); # First deparse command-line args if (defined $^I) { # deparse -i print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n); } if ($^W) { # deparse -w print qq(BEGIN { \$^W = $^W; }\n); } if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0 my $fs = perlstring($/) || 'undef'; my $bs = perlstring($O::savebackslash) || 'undef'; print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n); } my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : (); my @UNITCHECKs = B::unitcheck_av->isa("B::AV") ? B::unitcheck_av->ARRAY : (); my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : (); my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : (); my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : (); my @names = qw(BEGIN UNITCHECK CHECK INIT END); my @blocks = \(@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs); while (@names) { my ($name, $blocks) = (shift @names, shift @blocks); for my $block (@$blocks) { $self->todo($block, 0, $name); } } $self->stash_subs(); local($SIG{"__DIE__"}) = sub { if ($self->{'curcop'}) { my $cop = $self->{'curcop'}; my($line, $file) = ($cop->line, $cop->file); print STDERR "While deparsing $file near line $line,\n"; } }; $self->{'curcv'} = main_cv; $self->{'curcvlex'} = undef; print $self->print_protos; @{$self->{'subs_todo'}} = sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}; my $root = main_root; local $B::overlay = {}; unless (null $root) { $self->pad_subs($self->{'curcv'}); # Check for a stub-followed-by-ex-cop, resulting from a program # consisting solely of sub declarations. For backward-compati- # bility (and sane output) we don’t want to emit the stub. # leave # enter # stub # ex-nextstate (or ex-dbstate) my $kid; if ( $root->name eq 'leave' and ($kid = $root->first)->name eq 'enter' and !null($kid = $kid->sibling) and $kid->name eq 'stub' and !null($kid = $kid->sibling) and $kid->name eq 'null' and class($kid) eq 'COP' and null $kid->sibling ) { # ignore } else { $self->pessimise($root, main_start); print $self->indent($self->deparse_root($root)), "\n"; } } my @text; while (scalar(@{$self->{'subs_todo'}})) { push @text, $self->next_todo; } print $self->indent(join("", @text)), "\n" if @text; # Print __DATA__ section, if necessary no strict 'refs'; my $laststash = defined $self->{'curcop'} ? $self->{'curcop'}->stash->NAME : $self->{'curstash'}; if (defined *{$laststash."::DATA"}{IO}) { print $self->keyword("package") . " $laststash;\n" unless $laststash eq $self->{'curstash'}; print $self->keyword("__DATA__") . "\n"; print readline(*{$laststash."::DATA"}); } } } sub coderef2text { my $self = shift; my $sub = shift; croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE"); $self->init(); local $self->{in_coderef2text} = 1; return $self->indent($self->deparse_sub(svref_2object($sub))); } my %strict_bits = do { local $^H; map +($_ => strict::bits($_)), qw/refs subs vars/ }; sub ambient_pragmas { my $self = shift; my ($hint_bits, $warning_bits, $hinthash) = (0); while (@_ > 1) { my $name = shift(); my $val = shift(); if ($name eq 'strict') { require strict; if ($val eq 'none') { $hint_bits &= $strict_bits{$_} for qw/refs subs vars/; next(); } my @names; if ($val eq "all") { @names = qw/refs subs vars/; } elsif (ref $val) { @names = @$val; } else { @names = split' ', $val; } $hint_bits |= $strict_bits{$_} for @names; } elsif ($name eq 'integer' || $name eq 'bytes' || $name eq 'utf8') { require "$name.pm"; if ($val) { $hint_bits |= ${$::{"${name}::"}{"hint_bits"}}; } else { $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}}; } } elsif ($name eq 're') { require re; if ($val eq 'none') { $hint_bits &= ~re::bits(qw/taint eval/); next(); } my @names; if ($val eq 'all') { @names = qw/taint eval/; } elsif (ref $val) { @names = @$val; } else { @names = split' ',$val; } $hint_bits |= re::bits(@names); } elsif ($name eq 'warnings') { if ($val eq 'none') { $warning_bits = $warnings::NONE; next(); } my @names; if (ref $val) { @names = @$val; } else { @names = split/\s+/, $val; } $warning_bits = $warnings::NONE if !defined ($warning_bits); $warning_bits |= warnings::bits(@names); } elsif ($name eq 'warning_bits') { $warning_bits = $val; } elsif ($name eq 'hint_bits') { $hint_bits = $val; } elsif ($name eq '%^H') { $hinthash = $val; } else { croak "Unknown pragma type: $name"; } } if (@_) { croak "The ambient_pragmas method expects an even number of args"; } $self->{'ambient_warnings'} = $warning_bits; $self->{'ambient_hints'} = $hint_bits; $self->{'ambient_hinthash'} = $hinthash; } # This method is the inner loop, so try to keep it simple sub deparse { my $self = shift; my($op, $cx) = @_; Carp::confess("Null op in deparse") if !defined($op) || class($op) eq "NULL"; my $meth = "pp_" . $op->name; return $self->$meth($op, $cx); } sub indent { my $self = shift; my $txt = shift; # \cK also swallows a preceding line break when followed by a # semicolon. $txt =~ s/\n\cK;//g; my @lines = split(/\n/, $txt); my $leader = ""; my $level = 0; my $line; for $line (@lines) { my $cmd = substr($line, 0, 1); if ($cmd eq "\t" or $cmd eq "\b") { $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'}; if ($self->{'use_tabs'}) { $leader = "\t" x ($level / 8) . " " x ($level % 8); } else { $leader = " " x $level; } $line = substr($line, 1); } if (index($line, "\f") > 0) { $line =~ s/\f/\n/; } if (substr($line, 0, 1) eq "\f") { $line = substr($line, 1); # no indent } else { $line = $leader . $line; } $line =~ s/\cK;?//g; } return join("\n", @lines); } sub pad_subs { my ($self, $cv) = @_; my $padlist = $cv->PADLIST; my @names = $padlist->ARRAYelt(0)->ARRAY; my @values = $padlist->ARRAYelt(1)->ARRAY; my @todo; PADENTRY: for my $ix (0.. $#names) { for $_ ($names[$ix]) { next if class($_) eq "SPECIAL"; my $name = $_->PVX; if (defined $name && $name =~ /^&./) { my $low = $_->COP_SEQ_RANGE_LOW; my $flags = $_->FLAGS; my $outer = $flags & PADNAMEt_OUTER; if ($flags & SVpad_OUR) { push @todo, [$low, undef, 0, $_] # [seq, no cv, not format, padname] unless $outer; next; } my $protocv = $flags & SVpad_STATE ? $values[$ix] : $_->PROTOCV; if (class ($protocv) ne 'CV') { my $flags = $flags; my $cv = $cv; my $name = $_; while ($flags & PADNAMEt_OUTER && class ($protocv) ne 'CV') { $cv = $cv->OUTSIDE; next PADENTRY if class($cv) eq 'SPECIAL'; # XXX freed? my $padlist = $cv->PADLIST; my $ix = $name->PARENT_PAD_INDEX; $name = $padlist->NAMES->ARRAYelt($ix); $flags = $name->FLAGS; $protocv = $flags & SVpad_STATE ? $padlist->ARRAYelt(1)->ARRAYelt($ix) : $name->PROTOCV; } } my $defined_in_this_sub = ${$protocv->OUTSIDE} == $$cv || do { my $other = $protocv->PADLIST; $$other && $other->outid == $padlist->id; }; if ($flags & PADNAMEt_OUTER) { next unless $defined_in_this_sub; push @todo, [$protocv->OUTSIDE_SEQ, $protocv, 0, $_]; next; } my $outseq = $protocv->OUTSIDE_SEQ; if ($outseq <= $low) { # defined before its name is visible, so it’s gotta be # declared and defined at once: my sub foo { ... } push @todo, [$low, $protocv, 0, $_]; } else { # declared and defined separately: my sub f; sub f { ... } push @todo, [$low, undef, 0, $_]; push @todo, [$outseq, $protocv, 0, $_] if $defined_in_this_sub; } } }} @{$self->{'subs_todo'}} = sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo } # 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 top is an ex-argcheck, which is a placeholder # indicating a signature subtree. # # Return a signature string, or an empty list if no deparseable as a # signature sub deparse_argops { my ($self, $topop, $cv) = @_; my @sig; $topop = $topop->first; return unless $$topop and $topop->name eq 'lineseq'; # last op should be nextstate my $last = $topop->last; return unless $$last and ( _op_is_or_was($last, OP_NEXTSTATE) or _op_is_or_was($last, OP_DBSTATE)); # first OP_NEXTSTATE my $o = $topop->first; return unless $$o; return if $o->label; # OP_ARGCHECK $o = $o->sibling; return unless $$o and $o->name eq 'argcheck'; 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, terminated # by a final nextstate while (1) { $o = $o->sibling; return unless $$o; # skip trailing nextstate last if $$o == $$last; # OP_NEXTSTATE return unless $o->name =~ /^(next|db)state$/; return if $o->label; # OP_ARGELEM $o = $o->sibling; last unless $$o; if ($o->name eq 'argelem') { my $ix = $o->string($cv); while (++$last_ix < $ix) { push @sig, $last_ix < $mandatory ? '$' : '$='; } my $var = $self->padname($o->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 ($o->flags & OPf_KIDS) { my $kid = $o->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 ($o->name eq 'null' and ($o->flags & OPf_KIDS) and $o->first->name eq 'argdefelem') { # special case - a void context default expression: $ = expr my $defop = $o->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 { return; } } while (++$last_ix < $params) { push @sig, $last_ix < $mandatory ? '$' : '$='; } push @sig, $slurpy if $slurpy and !$seen_slurpy; return (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 @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) { 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)) { 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; local($self->{'curcvlex'}); local(@$self{qw'curstash warnings hints hinthash'}) = @$self{qw'curstash warnings hints hinthash'}; my $body; my $root = $cv->ROOT; local $B::overlay = {}; if (not null $root) { $self->pad_subs($cv); $self->pessimise($root, $cv->START); my $lineseq = $root->first; # stub sub may have single op rather than list of ops my $is_list = ($lineseq->name eq "lineseq"); my $firstop = $is_list ? $lineseq->first : $lineseq; # Try to deparse first subtree as a signature if possible. # Top of signature subtree has an ex-argcheck as a placeholder if ( $has_sig and $$firstop and $firstop->name eq 'null' and $firstop->targ == OP_ARGCHECK ) { my ($mysig) = $self->deparse_argops($firstop, $cv); if (defined $mysig) { $sig = $mysig; $firstop = $is_list ? $firstop->sibling : undef; } } if ($is_list && $firstop) { 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); $body .= ";\n$subs" if length($subs); } } elsif ($firstop) { $body = $self->deparse($root->first, 0); } else { $body = ';'; # stub sub } 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 $body = "{ " . $self->const($sv, 0) . " }\n"; } else { # XSUB? (or just a declaration) $body = ';' } } $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 { my $self = shift; my $form = shift; my @text; local($self->{'curcv'}) = $form; local($self->{'curcvlex'}); local($self->{'in_format'}) = 1; local(@$self{qw'curstash warnings hints hinthash'}) = @$self{qw'curstash warnings hints hinthash'}; my $op = $form->ROOT; local $B::overlay = {}; $self->pessimise($op, $form->START); my $kid; return "\f." if $op->first->name eq 'stub' || $op->first->name eq 'nextstate'; $op = $op->first->first; # skip leavewrite, lineseq while (not null $op) { $op = $op->sibling; # skip nextstate my @exprs; $kid = $op->first->sibling; # skip pushmark push @text, "\f".$self->const_sv($kid)->PV; $kid = $kid->sibling; for (; not null $kid; $kid = $kid->sibling) { push @exprs, $self->deparse($kid, -1); $exprs[-1] =~ s/;\z//; } push @text, "\f".join(", ", @exprs)."\n" if @exprs; $op = $op->sibling; } return join("", @text) . "\f."; } sub is_scope { my $op = shift; return $op->name eq "leave" || $op->name eq "scope" || $op->name eq "lineseq" || ($op->name eq "null" && class($op) eq "UNOP" && (is_scope($op->first) || $op->first->name eq "enter")); } sub is_state { my $name = $_[0]->name; return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate"; } sub is_miniwhile { # check for one-line loop ('foo() while $y--') my $op = shift; return (!null($op) and null($op->sibling) and $op->name eq "null" and class($op) eq "UNOP" and (($op->first->name =~ /^(and|or)$/ and $op->first->first->sibling->name eq "lineseq") or ($op->first->name eq "lineseq" and not null $op->first->first->sibling and $op->first->first->sibling->name eq "unstack") )); } # Check if the op and its sibling are the initialization and the rest of a # for (..;..;..) { ... } loop sub is_for_loop { my $op = shift; # This OP might be almost anything, though it won't be a # nextstate. (It's the initialization, so in the canonical case it # will be an sassign.) The sibling is (old style) a lineseq whose # first child is a nextstate and whose second is a leaveloop, or # (new style) an unstack whose sibling is a leaveloop. my $lseq = $op->sibling; return 0 unless !is_state($op) and !null($lseq); if ($lseq->name eq "lineseq") { if ($lseq->first && !null($lseq->first) && is_state($lseq->first) && (my $sib = $lseq->first->sibling)) { return (!null($sib) && $sib->name eq "leaveloop"); } } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) { my $sib = $lseq->sibling; return $sib && !null($sib) && $sib->name eq "leaveloop"; } return 0; } sub is_scalar { my $op = shift; return ($op->name eq "rv2sv" or $op->name eq "padsv" or $op->name eq "gv" or # only in array/hash constructs $op->flags & OPf_KIDS && !null($op->first) && $op->first->name eq "gvsv"); } sub maybe_parens { my $self = shift; my($text, $cx, $prec) = @_; if ($prec < $cx # unary ops nest just fine or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21 or $self->{'parens'}) { $text = "($text)"; # In a unop, let parent reuse our parens; see maybe_parens_unop $text = "\cS" . $text if $cx == 16; return $text; } else { return $text; } } # same as above, but get around the 'if it looks like a function' rule sub maybe_parens_unop { my $self = shift; my($name, $kid, $cx) = @_; if ($cx > 16 or $self->{'parens'}) { $kid = $self->deparse($kid, 1); if ($name eq "umask" && $kid =~ /^\d+$/) { $kid = sprintf("%#o", $kid); } return $self->keyword($name) . "($kid)"; } else { $kid = $self->deparse($kid, 16); if ($name eq "umask" && $kid =~ /^\d+$/) { $kid = sprintf("%#o", $kid); } $name = $self->keyword($name); if (substr($kid, 0, 1) eq "\cS") { # use kid's parens return $name . substr($kid, 1); } elsif (substr($kid, 0, 1) eq "(") { # avoid looks-like-a-function trap with extra parens # ('+' can lead to ambiguities) return "$name(" . $kid . ")"; } else { return "$name $kid"; } } } sub maybe_parens_func { my $self = shift; my($func, $text, $cx, $prec) = @_; if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) { return "$func($text)"; } else { return "$func $text"; } } sub find_our_type { my ($self, $name) = @_; $self->populate_curcvlex() if !defined $self->{'curcvlex'}; my $seq = $self->{'curcop'} ? $self->{'curcop'}->cop_seq : 0; for my $a (@{$self->{'curcvlex'}{"o$name"}}) { my ($st, undef, $padname) = @$a; if ($st >= $seq && $padname->FLAGS & SVpad_TYPED) { return $padname->SvSTASH->NAME; } } return ''; } sub maybe_local { my $self = shift; my($op, $cx, $text) = @_; my $name = $op->name; my $our_intro = ($name =~ /^(?:(?:gv|rv2)[ash]v|split|refassign |lv(?:av)?ref)$/x) ? OPpOUR_INTRO : 0; my $lval_intro = $name eq 'split' ? 0 : OPpLVAL_INTRO; # The @a in \(@a) isn't in ref context, but only when the # parens are there. my $need_parens = $self->{'in_refgen'} && $name =~ /[ah]v\z/ && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS; if ((my $priv = $op->private) & ($lval_intro|$our_intro)) { my @our_local; push @our_local, "local" if $priv & $lval_intro; push @our_local, "our" if $priv & $our_intro; my $our_local = join " ", map $self->keyword($_), @our_local; if( $our_local[-1] eq 'our' ) { if ( $text !~ /^\W(\w+::)*\w+\z/ and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/ ) { die "Unexpected our($text)\n"; } $text =~ s/(\w+::)+//; if (my $type = $self->find_our_type($text)) { $our_local .= ' ' . $type; } } return $need_parens ? "($text)" : $text if $self->{'avoid_local'}{$$op}; if ($need_parens) { return "$our_local($text)"; } elsif (want_scalar($op) || $our_local eq 'our') { return "$our_local $text"; } else { return $self->maybe_parens_func("$our_local", $text, $cx, 16); } } else { return $need_parens ? "($text)" : $text; } } sub maybe_targmy { my $self = shift; my($op, $cx, $func, @args) = @_; if ($op->private & OPpTARGET_MY) { my $var = $self->padname($op->targ); my $val = $func->($self, $op, 7, @args); return $self->maybe_parens("$var = $val", $cx, 7); } else { return $func->($self, $op, $cx, @args); } } sub padname_sv { my $self = shift; my $targ = shift; return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ); } sub maybe_my { my $self = shift; my($op, $cx, $text, $padname, $forbid_parens) = @_; # The @a in \(@a) isn't in ref context, but only when the # parens are there. my $need_parens = !$forbid_parens && $self->{'in_refgen'} && $op->name =~ /[ah]v\z/ && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS; # The @a in \my @a must not have parens. if (!$need_parens && $self->{'in_refgen'}) { $forbid_parens = 1; } if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { # Check $padname->FLAGS for statehood, rather than $op->private, # because enteriter ops do not carry the flag. my $my = $self->keyword($padname->FLAGS & SVpad_STATE ? "state" : "my"); if ($padname->FLAGS & SVpad_TYPED) { $my .= ' ' . $padname->SvSTASH->NAME; } if ($need_parens) { return "$my($text)"; } elsif ($forbid_parens || want_scalar($op)) { return "$my $text"; } else { return $self->maybe_parens_func($my, $text, $cx, 16); } } else { return $need_parens ? "($text)" : $text; } } # The following OPs don't have functions: # pp_padany -- does not exist after parsing sub AUTOLOAD { if ($AUTOLOAD =~ s/^.*::pp_//) { warn "unexpected OP_". ($_[1]->type == OP_CUSTOM ? "CUSTOM ($AUTOLOAD)" : uc $AUTOLOAD); return "XXX"; } else { die "Undefined subroutine $AUTOLOAD called"; } } sub DESTROY {} # Do not AUTOLOAD # $root should be the op which represents the root of whatever # we're sequencing here. If it's undefined, then we don't append # any subroutine declarations to the deparsed ops, otherwise we # append appropriate declarations. sub lineseq { my($self, $root, $cx, @ops) = @_; my($expr, @exprs); my $out_cop = $self->{'curcop'}; my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef; my $limit_seq; if (defined $root) { $limit_seq = $out_seq; my $nseq; $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling}; $limit_seq = $nseq if !defined($limit_seq) or defined($nseq) && $nseq < $limit_seq; } $limit_seq = $self->{'limit_seq'} if defined($self->{'limit_seq'}) && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq); local $self->{'limit_seq'} = $limit_seq; $self->walk_lineseq($root, \@ops, sub { push @exprs, $_[0]} ); my $sep = $cx ? '; ' : ";\n"; my $body = join($sep, grep {length} @exprs); my $subs = ""; if (defined $root && defined $limit_seq && !$self->{'in_format'}) { $subs = join "\n", $self->seq_subs($limit_seq); } return join($sep, grep {length} $body, $subs); } sub scopeop { my($real_block, $self, $op, $cx) = @_; my $kid; my @kids; local(@$self{qw'curstash warnings hints hinthash'}) = @$self{qw'curstash warnings hints hinthash'} if $real_block; if ($real_block) { $kid = $op->first->sibling; # skip enter if (is_miniwhile($kid)) { my $top = $kid->first; my $name = $top->name; if ($name eq "and") { $name = $self->keyword("while"); } elsif ($name eq "or") { $name = $self->keyword("until"); } else { # no conditional -> while 1 or until 0 return $self->deparse($top->first, 1) . " " . $self->keyword("while") . " 1"; } my $cond = $top->first; my $body = $cond->sibling->first; # skip lineseq $cond = $self->deparse($cond, 1); $body = $self->deparse($body, 1); return "$body $name $cond"; } } else { $kid = $op->first; } for (; !null($kid); $kid = $kid->sibling) { push @kids, $kid; } if ($cx > 0) { # inside an expression, (a do {} while for lineseq) my $body = $self->lineseq($op, 0, @kids); return is_lexical_subs(@kids) ? $body : ($self->lex_in_scope("&do") ? "CORE::do" : "do") . " {\n\t$body\n\b}"; } else { my $lineseq = $self->lineseq($op, $cx, @kids); return (length ($lineseq) ? "$lineseq;" : ""); } } sub pp_scope { scopeop(0, @_); } sub pp_lineseq { scopeop(0, @_); } sub pp_leave { scopeop(1, @_); } # This is a special case of scopeop and lineseq, for the case of the # main_root. The difference is that we print the output statements as # soon as we get them, for the sake of impatient users. sub deparse_root { my $self = shift; my($op) = @_; local(@$self{qw'curstash warnings hints hinthash'}) = @$self{qw'curstash warnings hints hinthash'}; my @kids; return if null $op->first; # Can happen, e.g., for Bytecode without -k for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) { push @kids, $kid; } $self->walk_lineseq($op, \@kids, sub { return unless length $_[0]; print $self->indent($_[0].';'); print "\n" unless $_[1] == $#kids; }); } sub walk_lineseq { my ($self, $op, $kids, $callback) = @_; my @kids = @$kids; for (my $i = 0; $i < @kids; $i++) { my $expr = ""; if (is_state $kids[$i]) { $expr = $self->deparse($kids[$i++], 0); if ($i > $#kids) { $callback->($expr, $i); last; } } if (is_for_loop($kids[$i])) { $callback->($expr . $self->for_loop($kids[$i], 0), $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1); next; } my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2); $expr2 =~ s/^sub :(?!:)/+sub :/; # statement label otherwise $expr .= $expr2; $callback->($expr, $i); } } # The BEGIN {} is used here because otherwise this code isn't executed # when you run B::Deparse on itself. my %globalnames; BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC", "ENV", "ARGV", "ARGVOUT", "_"); } sub gv_name { my $self = shift; my $gv = shift; my $raw = shift; #Carp::confess() unless ref($gv) eq "B::GV"; my $cv = $gv->FLAGS & SVf_ROK ? $gv->RV : 0; my $stash = ($cv || $gv)->STASH->NAME; my $name = $raw ? $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME : $cv ? B::safename($cv->NAME_HEK || $cv->GV->NAME) : $gv->SAFENAME; if ($stash eq 'main' && $name =~ /^::/) { $stash = '::'; } elsif (($stash eq 'main' && ($globalnames{$name} || $name =~ /^[^A-Za-z_:]/)) or ($stash eq $self->{'curstash'} && !$globalnames{$name} && ($stash eq 'main' || $name !~ /::/)) ) { $stash = ""; } else { $stash = $stash . "::"; } if (!$raw and $name =~ /^(\^..|{)/) { $name = "{$name}"; # ${^WARNING_BITS}, etc and ${ } return $stash . $name; } # Return the name to use for a stash variable. # If a lexical with the same name is in scope, or # if strictures are enabled, it may need to be # fully-qualified. sub stash_variable { my ($self, $prefix, $name, $cx) = @_; return $prefix.$self->maybe_qualify($prefix, $name) if $name =~ /::/; unless ($prefix eq '$' || $prefix eq '@' || $prefix eq '&' || #' $prefix eq '%' || $prefix eq '$#') { return "$prefix$name"; } if ($name =~ /^[^[:alpha:]_+-]$/) { if (defined $cx && $cx == 26) { if ($prefix eq '@') { return "$prefix\{$name}"; } elsif ($name eq '#') { return '${#}' } # "${#}a" vs "$#a" } if ($prefix eq '$#') { return "\$#{$name}"; } } return $prefix . $self->maybe_qualify($prefix, $name); } my %unctrl = # portable to EBCDIC ( "\c@" => '@', # unused "\cA" => 'A', "\cB" => 'B', "\cC" => 'C', "\cD" => 'D', "\cE" => 'E', "\cF" => 'F', "\cG" => 'G', "\cH" => 'H', "\cI" => 'I', "\cJ" => 'J', "\cK" => 'K', "\cL" => 'L', "\cM" => 'M', "\cN" => 'N', "\cO" => 'O', "\cP" => 'P', "\cQ" => 'Q', "\cR" => 'R', "\cS" => 'S', "\cT" => 'T', "\cU" => 'U', "\cV" => 'V', "\cW" => 'W', "\cX" => 'X', "\cY" => 'Y', "\cZ" => 'Z', "\c[" => '[', # unused "\c\\" => '\\', # unused "\c]" => ']', # unused "\c_" => '_', # unused ); # Return just the name, without the prefix. It may be returned as a quoted # string. The second return value is a boolean indicating that. sub stash_variable_name { my($self, $prefix, $gv) = @_; my $name = $self->gv_name($gv, 1); $name = $self->maybe_qualify($prefix,$name); if ($name =~ /^(?:\S|(?!\d)[\ca-\cz]?(?:\w|::)*|\d+)\z/) { $name =~ s/^([\ca-\cz])/'^' . $unctrl{$1}/e; $name =~ /^(\^..|{)/ and $name = "{$name}"; return $name, 0; # not quoted } else { single_delim("q", "'", $name, $self), 1; } } sub maybe_qualify { my ($self,$prefix,$name) = @_; my $v = ($prefix eq '$#' ? '@' : $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" or $self->lex_in_scope($v); # conflicts with "my" variable return $name; } sub lex_in_scope { my ($self, $name, $our) = @_; substr $name, 0, 0, = $our ? 'o' : 'm'; # our/my $self->populate_curcvlex() if !defined $self->{'curcvlex'}; return 0 if !defined($self->{'curcop'}); my $seq = $self->{'curcop'}->cop_seq; return 0 if !exists $self->{'curcvlex'}{$name}; for my $a (@{$self->{'curcvlex'}{$name}}) { my ($st, $en) = @$a; return 1 if $seq > $st && $seq <= $en; } return 0; } sub populate_curcvlex { my $self = shift; for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) { my $padlist = $cv->PADLIST; # an undef CV still in lexical chain next if class($padlist) eq "SPECIAL"; my @padlist = $padlist->ARRAY; my @ns = $padlist[0]->ARRAY; for (my $i=0; $i<@ns; ++$i) { next if class($ns[$i]) eq "SPECIAL"; if (class($ns[$i]) eq "PV") { # Probably that pesky lexical @_ next; } my $name = $ns[$i]->PVX; next unless defined $name; my ($seq_st, $seq_en) = ($ns[$i]->FLAGS & SVf_FAKE) ? (0, 999999) : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH); push @{$self->{'curcvlex'}{ ($ns[$i]->FLAGS & SVpad_OUR ? 'o' : 'm') . $name }}, [$seq_st, $seq_en, $ns[$i]]; } } } sub find_scope_st { ((find_scope(@_))[0]); } sub find_scope_en { ((find_scope(@_))[1]); } # Recurses down the tree, looking for pad variable introductions and COPs sub find_scope { my ($self, $op, $scope_st, $scope_en) = @_; carp("Undefined op in find_scope") if !defined $op; return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS; my @queue = ($op); while(my $op = shift @queue ) { for (my $o=$op->first; $$o; $o=$o->sibling) { if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) { my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW); my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH; $scope_st = $s if !defined($scope_st) || $s < $scope_st; $scope_en = $e if !defined($scope_en) || $e > $scope_en; return ($scope_st, $scope_en); } elsif (is_state($o)) { my $c = $o->cop_seq; $scope_st = $c if !defined($scope_st) || $c < $scope_st; $scope_en = $c if !defined($scope_en) || $c > $scope_en; return ($scope_st, $scope_en); } elsif ($o->flags & OPf_KIDS) { unshift (@queue, $o); } } } return ($scope_st, $scope_en); } # Returns a list of subs which should be inserted before the COP sub cop_subs { my ($self, $op, $out_seq) = @_; my $seq = $op->cop_seq; $seq = $out_seq if defined($out_seq) && $out_seq < $seq; return $self->seq_subs($seq); } sub seq_subs { my ($self, $seq) = @_; my @text; #push @text, "# ($seq)\n"; return "" if !defined $seq; my @pending; while (scalar(@{$self->{'subs_todo'}}) and $seq > $self->{'subs_todo'}[0][0]) { my $cv = $self->{'subs_todo'}[0][1]; # Skip the OUTSIDE check for lexical subs. We may be deparsing a # cloned anon sub with lexical subs declared in it, in which case # the OUTSIDE pointer points to the anon protosub. my $lexical = ref $self->{'subs_todo'}[0][3]; my $outside = !$lexical && $cv && $cv->OUTSIDE; if (!$lexical and $cv and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}}) { push @pending, shift @{$self->{'subs_todo'}}; next; } push @text, $self->next_todo; } unshift @{$self->{'subs_todo'}}, @pending; return @text; } sub _features_from_bundle { my ($hints, $hh) = @_; foreach (@{$feature::feature_bundle{@feature::hint_bundles[$hints >> $feature::hint_shift]}}) { $hh->{$feature::feature{$_}} = 1; } return $hh; } # generate any pragmas, 'package foo' etc needed to synchronise # with the given cop sub pragmata { my $self = shift; my($op) = @_; my @text; my $stash = $op->stashpv; if ($stash ne $self->{'curstash'}) { push @text, $self->keyword("package") . " $stash;\n"; $self->{'curstash'} = $stash; } my $warnings = $op->warnings; my $warning_bits; if ($warnings->isa("B::SPECIAL") && $$warnings == 4) { $warning_bits = $warnings::Bits{"all"} & WARN_MASK; } elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) { $warning_bits = $warnings::NONE; } elsif ($warnings->isa("B::SPECIAL")) { $warning_bits = undef; } else { $warning_bits = $warnings->PV & WARN_MASK; } if (defined ($warning_bits) and !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) { push @text, $self->declare_warnings($self->{'warnings'}, $warning_bits); $self->{'warnings'} = $warning_bits; } my $hints = $op->hints; my $old_hints = $self->{'hints'}; if ($self->{'hints'} != $hints) { push @text, $self->declare_hints($self->{'hints'}, $hints); $self->{'hints'} = $hints; } my $newhh; $newhh = $op->hints_hash->HASH; { # feature bundle hints my $from = $old_hints & $feature::hint_mask; my $to = $ hints & $feature::hint_mask; if ($from != $to) { if ($to == $feature::hint_mask) { if ($self->{'hinthash'}) { delete $self->{'hinthash'}{$_} for grep /^feature_/, keys %{$self->{'hinthash'}}; } else { $self->{'hinthash'} = {} } $self->{'hinthash'} = _features_from_bundle($from, $self->{'hinthash'}); } else { my $bundle = $feature::hint_bundles[$to >> $feature::hint_shift]; $bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12 push @text, $self->keyword("no") . " feature ':all';\n", $self->keyword("use") . " feature ':$bundle';\n"; } } } { push @text, $self->declare_hinthash( $self->{'hinthash'}, $newhh, $self->{indent_size}, $self->{hints}, ); $self->{'hinthash'} = $newhh; } return join("", @text); } # Notice how subs and formats are inserted between statements here; # also $[ assignments and pragmas. sub pp_nextstate { my $self = shift; my($op, $cx) = @_; $self->{'curcop'} = $op; my @text; my @subs = $self->cop_subs($op); if (@subs) { # Special marker to swallow up the semicolon push @subs, "\cK"; } push @text, @subs; push @text, $self->pragmata($op); # This should go after of any branches that add statements, to # increase the chances that it refers to the same line it did in # the original program. if ($self->{'linenums'} && $cx != .5) { # $cx == .5 means in a format push @text, "\f#line " . $op->line . ' "' . $op->file, qq'"\n'; } push @text, $op->label . ": " if $op->label; return join("", @text); } sub declare_warnings { my ($self, $from, $to) = @_; $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"; } sub declare_hints { my ($self, $from, $to) = @_; my $use = $to & ~$from; my $no = $from & ~$to; my $decls = ""; for my $pragma (hint_pragmas($use)) { $decls .= $self->keyword("use") . " $pragma;\n"; } for my $pragma (hint_pragmas($no)) { $decls .= $self->keyword("no") . " $pragma;\n"; } return $decls; } # Internal implementation hints that the core sets automatically, so don't need # (or want) to be passed back to the user my %ignored_hints = ( 'open<' => 1, 'open>' => 1, ':' => 1, 'strict/refs' => 1, 'strict/subs' => 1, 'strict/vars' => 1, 'feature/bits' => 1, ); my %rev_feature; sub declare_hinthash { my ($self, $from, $to, $indent, $hints) = @_; my $doing_features = ($hints & $feature::hint_mask) == $feature::hint_mask; my @decls; my @features; my @unfeatures; # bugs? for my $key (sort keys %$to) { next if $ignored_hints{$key}; 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; push @decls, qq(\$^H{) . single_delim("q", "'", $key, $self) . qq(} = ) . ( defined $to->{$key} ? single_delim("q", "'", $to->{$key}, $self) : 'undef' ) . qq(;); } } for my $key (sort keys %$from) { next if $ignored_hints{$key}; my $is_feature = $key =~ /^feature_/; next if $is_feature and not $doing_features; if (!exists $to->{$key}) { push(@unfeatures, $key), next if $is_feature; push @decls, qq(delete \$^H{'$key'};); } } my @ret; if (@features || @unfeatures) { if (!%rev_feature) { %rev_feature = reverse %feature::feature } } if (@features) { push @ret, $self->keyword("use") . " feature " . join(", ", map "'$rev_feature{$_}'", @features) . ";\n"; } if (@unfeatures) { push @ret, $self->keyword("no") . " feature " . join(", ", map "'$rev_feature{$_}'", @unfeatures) . ";\n"; } @decls and push @ret, join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n\cK"; return @ret; } sub hint_pragmas { my ($bits) = @_; my (@pragmas, @strict); push @pragmas, "integer" if $bits & 0x1; for (sort keys %strict_bits) { push @strict, "'$_'" if $bits & $strict_bits{$_}; } if (@strict == keys %strict_bits) { push @pragmas, "strict"; } elsif (@strict) { push @pragmas, "strict " . join ', ', @strict; } push @pragmas, "bytes" if $bits & 0x8; return @pragmas; } sub pp_dbstate { pp_nextstate(@_) } sub pp_setstate { pp_nextstate(@_) } sub pp_unstack { return "" } # see also leaveloop my %feature_keywords = ( # keyword => 'feature', state => 'state', say => 'say', given => 'switch', when => 'switch', default => 'switch', break => 'switch', evalbytes=>'evalbytes', __SUB__ => '__SUB__', fc => 'fc', ); # keywords that are strong and also have a prototype # my %strong_proto_keywords = map { $_ => 1 } qw( pos prototype scalar study undef ); sub feature_enabled { my($self,$name) = @_; my $hh; my $hints = $self->{hints} & $feature::hint_mask; if ($hints && $hints != $feature::hint_mask) { $hh = _features_from_bundle($hints); } elsif ($hints) { $hh = $self->{'hinthash'} } return $hh && $hh->{"feature_$feature_keywords{$name}"} } sub keyword { my $self = shift; my $name = shift; return $name if $name =~ /^CORE::/; # just in case if (exists $feature_keywords{$name}) { return "CORE::$name" if not $self->feature_enabled($name); } # This sub may be called for a program that has no nextstate ops. In # that case we may have a lexical sub named no/use/sub in scope but # $self->lex_in_scope will return false because it depends on the # current nextstate op. So we need this alternate method if there is # no current cop. if (!$self->{'curcop'}) { $self->populate_curcvlex() if !defined $self->{'curcvlex'}; return "CORE::$name" if exists $self->{'curcvlex'}{"m&$name"} || exists $self->{'curcvlex'}{"o&$name"}; } elsif ($self->lex_in_scope("&$name") || $self->lex_in_scope("&$name", 1)) { return "CORE::$name"; } if ($strong_proto_keywords{$name} || ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/ && !defined eval{prototype "CORE::$name"}) ) { return $name } if ( exists $self->{subs_declared}{$name} or exists &{"$self->{curstash}::$name"} ) { return "CORE::$name" } return $name; } sub baseop { my $self = shift; my($op, $cx, $name) = @_; return $self->keyword($name); } sub pp_stub { "()" } sub pp_wantarray { baseop(@_, "wantarray") } sub pp_fork { baseop(@_, "fork") } sub pp_wait { maybe_targmy(@_, \&baseop, "wait") } sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") } sub pp_time { maybe_targmy(@_, \&baseop, "time") } sub pp_tms { baseop(@_, "times") } sub pp_ghostent { baseop(@_, "gethostent") } sub pp_gnetent { baseop(@_, "getnetent") } sub pp_gprotoent { baseop(@_, "getprotoent") } sub pp_gservent { baseop(@_, "getservent") } sub pp_ehostent { baseop(@_, "endhostent") } sub pp_enetent { baseop(@_, "endnetent") } sub pp_eprotoent { baseop(@_, "endprotoent") } sub pp_eservent { baseop(@_, "endservent") } sub pp_gpwent { baseop(@_, "getpwent") } sub pp_spwent { baseop(@_, "setpwent") } sub pp_epwent { baseop(@_, "endpwent") } sub pp_ggrent { baseop(@_, "getgrent") } sub pp_sgrent { baseop(@_, "setgrent") } sub pp_egrent { baseop(@_, "endgrent") } sub pp_getlogin { baseop(@_, "getlogin") } sub POSTFIX () { 1 } # I couldn't think of a good short name, but this is the category of # symbolic unary operators with interesting precedence sub pfixop { my $self = shift; my($op, $cx, $name, $prec, $flags) = (@_, 0); my $kid = $op->first; $kid = $self->deparse($kid, $prec); return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" # avoid confusion with filetests : $name eq '-' && $kid =~ /^[a-zA-Z](?!\w)/ ? "$name($kid)" : "$name$kid", $cx, $prec); } sub pp_preinc { pfixop(@_, "++", 23) } sub pp_predec { pfixop(@_, "--", 23) } sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } sub pp_i_preinc { pfixop(@_, "++", 23) } sub pp_i_predec { pfixop(@_, "--", 23) } sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) } *pp_ncomplement = *pp_complement; sub pp_scomplement { maybe_targmy(@_, \&pfixop, "~.", 21) } sub pp_negate { maybe_targmy(@_, \&real_negate) } sub real_negate { my $self = shift; my($op, $cx) = @_; if ($op->first->name =~ /^(i_)?negate$/) { # avoid --$x $self->pfixop($op, $cx, "-", 21.5); } else { $self->pfixop($op, $cx, "-", 21); } } sub pp_i_negate { pp_negate(@_) } sub pp_not { my $self = shift; my($op, $cx) = @_; if ($cx <= 4) { $self->listop($op, $cx, "not", $op->first); } else { $self->pfixop($op, $cx, "!", 21); } } sub unop { my $self = shift; my($op, $cx, $name, $nollafr) = @_; my $kid; if ($op->flags & OPf_KIDS) { $kid = $op->first; if (not $name) { # this deals with 'boolkeys' right now return $self->deparse($kid,$cx); } my $builtinname = $name; $builtinname =~ /^CORE::/ or $builtinname = "CORE::$name"; if (defined prototype($builtinname) && $builtinname ne 'CORE::readline' && prototype($builtinname) =~ /^;?\*/ && $kid->name eq "rv2gv") { $kid = $kid->first; } if ($nollafr) { if (($kid = $self->deparse($kid, 16)) !~ s/^\cS//) { # require foo() is a syntax error. $kid =~ /^(?!\d)\w/ and $kid = "($kid)"; } return $self->maybe_parens( $self->keyword($name) . " $kid", $cx, 16 ); } return $self->maybe_parens_unop($name, $kid, $cx); } else { return $self->maybe_parens( $self->keyword($name) . ($op->flags & OPf_SPECIAL ? "()" : ""), $cx, 16, ); } } sub pp_chop { maybe_targmy(@_, \&unop, "chop") } sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") } sub pp_schop { maybe_targmy(@_, \&unop, "chop") } sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") } sub pp_defined { unop(@_, "defined") } sub pp_undef { unop(@_, "undef") } sub pp_study { unop(@_, "study") } sub pp_ref { unop(@_, "ref") } sub pp_pos { maybe_local(@_, unop(@_, "pos")) } sub pp_sin { maybe_targmy(@_, \&unop, "sin") } sub pp_cos { maybe_targmy(@_, \&unop, "cos") } sub pp_rand { maybe_targmy(@_, \&unop, "rand") } sub pp_srand { unop(@_, "srand") } sub pp_exp { maybe_targmy(@_, \&unop, "exp") } sub pp_log { maybe_targmy(@_, \&unop, "log") } sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") } sub pp_int { maybe_targmy(@_, \&unop, "int") } sub pp_hex { maybe_targmy(@_, \&unop, "hex") } sub pp_oct { maybe_targmy(@_, \&unop, "oct") } sub pp_abs { maybe_targmy(@_, \&unop, "abs") } sub pp_length { maybe_targmy(@_, \&unop, "length") } sub pp_ord { maybe_targmy(@_, \&unop, "ord") } sub pp_chr { maybe_targmy(@_, \&unop, "chr") } sub pp_each { unop(@_, "each") } sub pp_values { unop(@_, "values") } sub pp_keys { unop(@_, "keys") } { no strict 'refs'; *{"pp_r$_"} = *{"pp_$_"} for qw< keys each values >; } sub pp_boolkeys { # no name because its an optimisation op that has no keyword unop(@_,""); } sub pp_aeach { unop(@_, "each") } sub pp_avalues { unop(@_, "values") } sub pp_akeys { unop(@_, "keys") } sub pp_pop { unop(@_, "pop") } sub pp_shift { unop(@_, "shift") } sub pp_caller { unop(@_, "caller") } sub pp_reset { unop(@_, "reset") } sub pp_exit { unop(@_, "exit") } sub pp_prototype { unop(@_, "prototype") } sub pp_close { unop(@_, "close") } sub pp_fileno { unop(@_, "fileno") } sub pp_umask { unop(@_, "umask") } sub pp_untie { unop(@_, "untie") } sub pp_tied { unop(@_, "tied") } sub pp_dbmclose { unop(@_, "dbmclose") } sub pp_getc { unop(@_, "getc") } sub pp_eof { unop(@_, "eof") } sub pp_tell { unop(@_, "tell") } sub pp_getsockname { unop(@_, "getsockname") } sub pp_getpeername { unop(@_, "getpeername") } sub pp_chdir { my ($self, $op, $cx) = @_; if (($op->flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS)) { my $kw = $self->keyword("chdir"); my $kid = $self->const_sv($op->first)->PV; my $code = $kw . ($cx >= 16 || $self->{'parens'} ? "($kid)" : " $kid"); maybe_targmy(@_, sub { $_[3] }, $code); } else { maybe_targmy(@_, \&unop, "chdir") } } sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") } sub pp_readlink { unop(@_, "readlink") } sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") } sub pp_readdir { unop(@_, "readdir") } sub pp_telldir { unop(@_, "telldir") } sub pp_rewinddir { unop(@_, "rewinddir") } sub pp_closedir { unop(@_, "closedir") } sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") } sub pp_localtime { unop(@_, "localtime") } sub pp_gmtime { unop(@_, "gmtime") } sub pp_alarm { unop(@_, "alarm") } sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") } sub pp_dofile { my $code = unop(@_, "do", 1); # llafr does not apply if ($code =~ s/^((?:CORE::)?do) \{/$1({/) { $code .= ')' } $code; } sub pp_entereval { unop( @_, $_[1]->private & OPpEVAL_BYTES ? 'evalbytes' : "eval" ) } sub pp_ghbyname { unop(@_, "gethostbyname") } sub pp_gnbyname { unop(@_, "getnetbyname") } sub pp_gpbyname { unop(@_, "getprotobyname") } sub pp_shostent { unop(@_, "sethostent") } sub pp_snetent { unop(@_, "setnetent") } sub pp_sprotoent { unop(@_, "setprotoent") } sub pp_sservent { unop(@_, "setservent") } sub pp_gpwnam { unop(@_, "getpwnam") } sub pp_gpwuid { unop(@_, "getpwuid") } sub pp_ggrnam { unop(@_, "getgrnam") } sub pp_ggrgid { unop(@_, "getgrgid") } sub pp_lock { unop(@_, "lock") } sub pp_continue { unop(@_, "continue"); } sub pp_break { unop(@_, "break"); } sub givwhen { my $self = shift; my($op, $cx, $givwhen) = @_; my $enterop = $op->first; my ($head, $block); if ($enterop->flags & OPf_SPECIAL) { $head = $self->keyword("default"); $block = $self->deparse($enterop->first, 0); } else { my $cond = $enterop->first; my $cond_str = $self->deparse($cond, 1); $head = "$givwhen ($cond_str)"; $block = $self->deparse($cond->sibling, 0); } return "$head {\n". "\t$block\n". "\b}\cK"; } sub pp_leavegiven { givwhen(@_, $_[0]->keyword("given")); } sub pp_leavewhen { givwhen(@_, $_[0]->keyword("when")); } sub pp_exists { my $self = shift; my($op, $cx) = @_; my $arg; my $name = $self->keyword("exists"); if ($op->private & OPpEXISTS_SUB) { # Checking for the existence of a subroutine return $self->maybe_parens_func($name, $self->pp_rv2cv($op->first, 16), $cx, 16); } if ($op->flags & OPf_SPECIAL) { # Array element, not hash element return $self->maybe_parens_func($name, $self->pp_aelem($op->first, 16), $cx, 16); } return $self->maybe_parens_func($name, $self->pp_helem($op->first, 16), $cx, 16); } sub pp_delete { my $self = shift; my($op, $cx) = @_; my $arg; my $name = $self->keyword("delete"); if ($op->private & (OPpSLICE|OPpKVSLICE)) { if ($op->flags & OPf_SPECIAL) { # Deleting from an array, not a hash return $self->maybe_parens_func($name, $self->pp_aslice($op->first, 16), $cx, 16); } return $self->maybe_parens_func($name, $self->pp_hslice($op->first, 16), $cx, 16); } else { if ($op->flags & OPf_SPECIAL) { # Deleting from an array, not a hash return $self->maybe_parens_func($name, $self->pp_aelem($op->first, 16), $cx, 16); } return $self->maybe_parens_func($name, $self->pp_helem($op->first, 16), $cx, 16); } } sub pp_require { my $self = shift; my($op, $cx) = @_; my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require'; my $kid = $op->first; if ($kid->name eq 'const') { my $priv = $kid->private; my $sv = $self->const_sv($kid); my $arg; if ($priv & OPpCONST_BARE) { $arg = $sv->PV; $arg =~ s[/][::]g; $arg =~ s/\.pm//g; } elsif ($priv & OPpCONST_NOVER) { $opname = $self->keyword('no'); $arg = $self->const($sv, 16); } elsif ((my $tmp = $self->const($sv, 16)) =~ /^v/) { $arg = $tmp; } if ($arg) { return $self->maybe_parens("$opname $arg", $cx, 16); } } $self->unop( $op, $cx, $opname, 1, # llafr does not apply ); } sub pp_scalar { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; if (not null $kid->sibling) { # XXX Was a here-doc return $self->dquote($op); } $self->unop(@_, "scalar"); } sub padval { my $self = shift; my $targ = shift; return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ); } sub anon_hash_or_list { my $self = shift; my($op, $cx) = @_; my($pre, $post) = @{{"anonlist" => ["[","]"], "anonhash" => ["{","}"]}->{$op->name}}; my($expr, @exprs); $op = $op->first->sibling; # skip pushmark for (; !null($op); $op = $op->sibling) { $expr = $self->deparse($op, 6); push @exprs, $expr; } if ($pre eq "{" and $cx < 1) { # Disambiguate that it's not a block $pre = "+{"; } return $pre . join(", ", @exprs) . $post; } sub pp_anonlist { my $self = shift; my ($op, $cx) = @_; if ($op->flags & OPf_SPECIAL) { return $self->anon_hash_or_list($op, $cx); } warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL"; return 'XXX'; } *pp_anonhash = \&pp_anonlist; sub pp_refgen { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; if ($kid->name eq "null") { my $anoncode = $kid = $kid->first; if ($anoncode->name eq "anonconst") { $anoncode = $anoncode->first->first->sibling; } if ($anoncode->name eq "anoncode" or !null($anoncode = $kid->sibling) and $anoncode->name eq "anoncode") { return $self->e_anoncode({ code => $self->padval($anoncode->targ) }); } elsif ($kid->name eq "pushmark") { my $sib_name = $kid->sibling->name; if ($sib_name eq 'entersub') { my $text = $self->deparse($kid->sibling, 1); # Always show parens for \(&func()), but only with -p otherwise $text = "($text)" if $self->{'parens'} or $kid->sibling->private & OPpENTERSUB_AMPER; return "\\$text"; } } } local $self->{'in_refgen'} = 1; $self->pfixop($op, $cx, "\\", 20); } sub e_anoncode { my ($self, $info) = @_; my $text = $self->deparse_sub($info->{code}); return $self->keyword("sub") . " $text"; } sub pp_srefgen { pp_refgen(@_) } sub pp_readline { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; if (is_scalar($kid) and $op->flags & OPf_SPECIAL and $self->deparse($kid, 1) eq 'ARGV') { return '<<>>'; } return $self->unop($op, $cx, "readline"); } sub pp_rcatline { my $self = shift; my($op) = @_; return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">"; } # Unary operators that can occur as pseudo-listops inside double quotes sub dq_unop { my $self = shift; my($op, $cx, $name, $prec, $flags) = (@_, 0, 0); my $kid; if ($op->flags & OPf_KIDS) { $kid = $op->first; # If there's more than one kid, the first is an ex-pushmark. $kid = $kid->sibling if not null $kid->sibling; return $self->maybe_parens_unop($name, $kid, $cx); } else { return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); } } sub pp_ucfirst { dq_unop(@_, "ucfirst") } sub pp_lcfirst { dq_unop(@_, "lcfirst") } sub pp_uc { dq_unop(@_, "uc") } sub pp_lc { dq_unop(@_, "lc") } sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") } sub pp_fc { dq_unop(@_, "fc") } sub loopex { my $self = shift; my ($op, $cx, $name) = @_; if (class($op) eq "PVOP") { $name .= " " . $op->pv; } elsif (class($op) eq "OP") { # no-op } elsif (class($op) eq "UNOP") { (my $kid = $self->deparse($op->first, 7)) =~ s/^\cS//; # last foo() is a syntax error. $kid =~ /^(?!\d)\w/ and $kid = "($kid)"; $name .= " $kid"; } return $self->maybe_parens($name, $cx, 7); } sub pp_last { loopex(@_, "last") } sub pp_next { loopex(@_, "next") } sub pp_redo { loopex(@_, "redo") } sub pp_goto { loopex(@_, "goto") } sub pp_dump { loopex(@_, "CORE::dump") } sub ftst { my $self = shift; my($op, $cx, $name) = @_; if (class($op) eq "UNOP") { # Genuine '-X' filetests are exempt from the LLAFR, but not # l?stat() if ($name =~ /^-/) { (my $kid = $self->deparse($op->first, 16)) =~ s/^\cS//; return $self->maybe_parens("$name $kid", $cx, 16); } return $self->maybe_parens_unop($name, $op->first, $cx); } elsif (class($op) =~ /^(SV|PAD)OP$/) { return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16); } else { # I don't think baseop filetests ever survive ck_ftst, but... return $name; } } sub pp_lstat { ftst(@_, "lstat") } sub pp_stat { ftst(@_, "stat") } sub pp_ftrread { ftst(@_, "-R") } sub pp_ftrwrite { ftst(@_, "-W") } sub pp_ftrexec { ftst(@_, "-X") } sub pp_fteread { ftst(@_, "-r") } sub pp_ftewrite { ftst(@_, "-w") } sub pp_fteexec { ftst(@_, "-x") } sub pp_ftis { ftst(@_, "-e") } sub pp_fteowned { ftst(@_, "-O") } sub pp_ftrowned { ftst(@_, "-o") } sub pp_ftzero { ftst(@_, "-z") } sub pp_ftsize { ftst(@_, "-s") } sub pp_ftmtime { ftst(@_, "-M") } sub pp_ftatime { ftst(@_, "-A") } sub pp_ftctime { ftst(@_, "-C") } sub pp_ftsock { ftst(@_, "-S") } sub pp_ftchr { ftst(@_, "-c") } sub pp_ftblk { ftst(@_, "-b") } sub pp_ftfile { ftst(@_, "-f") } sub pp_ftdir { ftst(@_, "-d") } sub pp_ftpipe { ftst(@_, "-p") } sub pp_ftlink { ftst(@_, "-l") } sub pp_ftsuid { ftst(@_, "-u") } sub pp_ftsgid { ftst(@_, "-g") } sub pp_ftsvtx { ftst(@_, "-k") } sub pp_fttty { ftst(@_, "-t") } sub pp_fttext { ftst(@_, "-T") } sub pp_ftbinary { ftst(@_, "-B") } sub SWAP_CHILDREN () { 1 } sub ASSIGN () { 2 } # has OP= variant sub LIST_CONTEXT () { 4 } # Assignment is in list context my(%left, %right); sub assoc_class { my $op = shift; my $name = $op->name; if ($name eq "concat" and $op->first->name eq "concat") { # avoid spurious '=' -- see comment in pp_concat return "concat"; } if ($name eq "null" and class($op) eq "UNOP" and $op->first->name =~ /^(and|x?or)$/ and null $op->first->sibling) { # Like all conditional constructs, OP_ANDs and OP_ORs are topped # with a null that's used as the common end point of the two # flows of control. For precedence purposes, ignore it. # (COND_EXPRs have these too, but we don't bother with # their associativity). return assoc_class($op->first); } return $name . ($op->flags & OPf_STACKED ? "=" : ""); } # Left associative operators, like '+', for which # $a + $b + $c is equivalent to ($a + $b) + $c BEGIN { %left = ('multiply' => 19, 'i_multiply' => 19, 'divide' => 19, 'i_divide' => 19, 'modulo' => 19, 'i_modulo' => 19, 'repeat' => 19, 'add' => 18, 'i_add' => 18, 'subtract' => 18, 'i_subtract' => 18, 'concat' => 18, 'left_shift' => 17, 'right_shift' => 17, 'bit_and' => 13, 'nbit_and' => 13, 'sbit_and' => 13, 'bit_or' => 12, 'bit_xor' => 12, 'sbit_or' => 12, 'sbit_xor' => 12, 'nbit_or' => 12, 'nbit_xor' => 12, 'and' => 3, 'or' => 2, 'xor' => 2, ); } sub deparse_binop_left { my $self = shift; my($op, $left, $prec) = @_; if ($left{assoc_class($op)} && $left{assoc_class($left)} and $left{assoc_class($op)} == $left{assoc_class($left)}) { return $self->deparse($left, $prec - .00001); } else { return $self->deparse($left, $prec); } } # Right associative operators, like '=', for which # $a = $b = $c is equivalent to $a = ($b = $c) BEGIN { %right = ('pow' => 22, 'sassign=' => 7, 'aassign=' => 7, 'multiply=' => 7, 'i_multiply=' => 7, 'divide=' => 7, 'i_divide=' => 7, 'modulo=' => 7, 'i_modulo=' => 7, 'repeat=' => 7, 'refassign' => 7, 'refassign=' => 7, 'add=' => 7, 'i_add=' => 7, 'subtract=' => 7, 'i_subtract=' => 7, 'concat=' => 7, 'left_shift=' => 7, 'right_shift=' => 7, 'bit_and=' => 7, 'sbit_and=' => 7, 'nbit_and=' => 7, 'nbit_or=' => 7, 'nbit_xor=' => 7, 'sbit_or=' => 7, 'sbit_xor=' => 7, 'andassign' => 7, 'orassign' => 7, ); } sub deparse_binop_right { my $self = shift; my($op, $right, $prec) = @_; if ($right{assoc_class($op)} && $right{assoc_class($right)} and $right{assoc_class($op)} == $right{assoc_class($right)}) { return $self->deparse($right, $prec - .00001); } else { return $self->deparse($right, $prec); } } sub binop { my $self = shift; my ($op, $cx, $opname, $prec, $flags) = (@_, 0); my $left = $op->first; my $right = $op->last; my $eq = ""; if ($op->flags & OPf_STACKED && $flags & ASSIGN) { $eq = "="; $prec = 7; } if ($flags & SWAP_CHILDREN) { ($left, $right) = ($right, $left); } my $leftop = $left; $left = $self->deparse_binop_left($op, $left, $prec); $left = "($left)" if $flags & LIST_CONTEXT and $left !~ /^(my|our|local|state|)\s*[\@%\(]/ || do { # Parenthesize if the left argument is a # lone repeat op. my $left = $leftop->first->sibling; $left->name eq 'repeat' && null($left->sibling); }; $right = $self->deparse_binop_right($op, $right, $prec); return $self->maybe_parens("$left $opname$eq $right", $cx, $prec); } sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) } sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) } sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) } sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) } sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) } sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) } sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) } sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) } *pp_nbit_and = *pp_bit_and; *pp_nbit_or = *pp_bit_or; *pp_nbit_xor = *pp_bit_xor; sub pp_sbit_and { maybe_targmy(@_, \&binop, "&.", 13, ASSIGN) } sub pp_sbit_or { maybe_targmy(@_, \&binop, "|.", 12, ASSIGN) } sub pp_sbit_xor { maybe_targmy(@_, \&binop, "^.", 12, ASSIGN) } sub pp_eq { binop(@_, "==", 14) } sub pp_ne { binop(@_, "!=", 14) } sub pp_lt { binop(@_, "<", 15) } sub pp_gt { binop(@_, ">", 15) } sub pp_ge { binop(@_, ">=", 15) } sub pp_le { binop(@_, "<=", 15) } sub pp_ncmp { binop(@_, "<=>", 14) } sub pp_i_eq { binop(@_, "==", 14) } sub pp_i_ne { binop(@_, "!=", 14) } sub pp_i_lt { binop(@_, "<", 15) } sub pp_i_gt { binop(@_, ">", 15) } sub pp_i_ge { binop(@_, ">=", 15) } sub pp_i_le { binop(@_, "<=", 15) } sub pp_i_ncmp { maybe_targmy(@_, \&binop, "<=>", 14) } sub pp_seq { binop(@_, "eq", 14) } sub pp_sne { binop(@_, "ne", 14) } sub pp_slt { binop(@_, "lt", 15) } sub pp_sgt { binop(@_, "gt", 15) } sub pp_sge { binop(@_, "ge", 15) } sub pp_sle { binop(@_, "le", 15) } sub pp_scmp { maybe_targmy(@_, \&binop, "cmp", 14) } sub pp_isa { binop(@_, "isa", 15) } sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) } sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) } sub pp_smartmatch { my ($self, $op, $cx) = @_; if (($op->flags & OPf_SPECIAL) && $self->{expand} < 2) { return $self->deparse($op->last, $cx); } else { binop(@_, "~~", 14); } } # '.' is special because concats-of-concats are optimized to save copying # by making all but the first concat stacked. The effect is as if the # programmer had written '($a . $b) .= $c', except legal. sub pp_concat { maybe_targmy(@_, \&real_concat) } sub real_concat { my $self = shift; my($op, $cx) = @_; my $left = $op->first; my $right = $op->last; my $eq = ""; my $prec = 18; if (($op->flags & OPf_STACKED) and !($op->private & OPpCONCAT_NESTED)) { # '.=' rather than optimised '.' $eq = "="; $prec = 7; } $left = $self->deparse_binop_left($op, $left, $prec); $right = $self->deparse_binop_right($op, $right, $prec); return $self->maybe_parens("$left .$eq $right", $cx, $prec); } sub pp_repeat { maybe_targmy(@_, \&repeat) } # 'x' is weird when the left arg is a list sub repeat { my $self = shift; my($op, $cx) = @_; my $left = $op->first; my $right = $op->last; my $eq = ""; my $prec = 19; if ($op->flags & OPf_STACKED) { $eq = "="; $prec = 7; } if (null($right)) { # list repeat; count is inside left-side ex-list # in 5.21.5 and earlier my $kid = $left->first->sibling; # skip pushmark my @exprs; for (; !null($kid->sibling); $kid = $kid->sibling) { push @exprs, $self->deparse($kid, 6); } $right = $kid; $left = "(" . join(", ", @exprs). ")"; } else { my $dolist = $op->private & OPpREPEAT_DOLIST; $left = $self->deparse_binop_left($op, $left, $dolist ? 1 : $prec); if ($dolist) { $left = "($left)"; } } $right = $self->deparse_binop_right($op, $right, $prec); return $self->maybe_parens("$left x$eq $right", $cx, $prec); } sub range { my $self = shift; my ($op, $cx, $type) = @_; my $left = $op->first; my $right = $left->sibling; $left = $self->deparse($left, 9); $right = $self->deparse($right, 9); return $self->maybe_parens("$left $type $right", $cx, 9); } sub pp_flop { my $self = shift; my($op, $cx) = @_; my $flip = $op->first; my $type = ($flip->flags & OPf_SPECIAL) ? "..." : ".."; return $self->range($flip->first, $cx, $type); } # one-line while/until is handled in pp_leave sub logop { my $self = shift; my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; my $left = $op->first; my $right = $op->first->sibling; $blockname &&= $self->keyword($blockname); if ($cx < 1 and is_scope($right) and $blockname and $self->{'expand'} < 7) { # if ($a) {$b} $left = $self->deparse($left, 1); $right = $self->deparse($right, 0); return "$blockname ($left) {\n\t$right\n\b}\cK"; } elsif ($cx < 1 and $blockname and not $self->{'parens'} and $self->{'expand'} < 7) { # $b if $a $right = $self->deparse($right, 1); $left = $self->deparse($left, 1); return "$right $blockname $left"; } elsif ($cx > $lowprec and $highop) { # $a && $b $left = $self->deparse_binop_left($op, $left, $highprec); $right = $self->deparse_binop_right($op, $right, $highprec); return $self->maybe_parens("$left $highop $right", $cx, $highprec); } else { # $a and $b $left = $self->deparse_binop_left($op, $left, $lowprec); $right = $self->deparse_binop_right($op, $right, $lowprec); return $self->maybe_parens("$left $lowop $right", $cx, $lowprec); } } sub pp_and { logop(@_, "and", 3, "&&", 11, "if") } sub pp_or { logop(@_, "or", 2, "||", 10, "unless") } sub pp_dor { logop(@_, "//", 10) } # xor is syntactically a logop, but it's really a binop (contrary to # old versions of opcode.pl). Syntax is what matters here. sub pp_xor { logop(@_, "xor", 2, "", 0, "") } sub logassignop { my $self = shift; my ($op, $cx, $opname) = @_; my $left = $op->first; my $right = $op->first->sibling->first; # skip sassign $left = $self->deparse($left, 7); $right = $self->deparse($right, 7); return $self->maybe_parens("$left $opname $right", $cx, 7); } sub pp_andassign { logassignop(@_, "&&=") } sub pp_orassign { logassignop(@_, "||=") } sub pp_dorassign { logassignop(@_, "//=") } my %cmpchain_cmpops = ( eq => ["==", 14], i_eq => ["==", 14], ne => ["!=", 14], i_ne => ["!=", 14], seq => ["eq", 14], sne => ["ne", 14], lt => ["<", 15], i_lt => ["<", 15], gt => [">", 15], i_gt => [">", 15], le => ["<=", 15], i_le => ["<=", 15], ge => [">=", 15], i_ge => [">=", 15], slt => ["lt", 15], sgt => ["gt", 15], sle => ["le", 15], sge => ["ge", 15], ); sub pp_cmpchain_and { my($self, $op, $cx) = @_; my($prec, $dep); while(1) { my($thiscmp, $rightcond); if($op->name eq "cmpchain_and") { $thiscmp = $op->first; $rightcond = $thiscmp->sibling; } else { $thiscmp = $op; } my $thiscmptype = $cmpchain_cmpops{$thiscmp->name} // (return "XXX"); if(defined $prec) { $thiscmptype->[1] == $prec or return "XXX"; $thiscmp->first->name eq "null" && !($thiscmp->first->flags & OPf_KIDS) or return "XXX"; } else { $prec = $thiscmptype->[1]; $dep = $self->deparse($thiscmp->first, $prec); } $dep .= " ".$thiscmptype->[0]." "; my $operand = $thiscmp->last; if(defined $rightcond) { $operand->name eq "cmpchain_dup" or return "XXX"; $operand = $operand->first; } $dep .= $self->deparse($operand, $prec); last unless defined $rightcond; if($rightcond->name eq "null" && ($rightcond->flags & OPf_KIDS) && $rightcond->first->name eq "cmpchain_and") { $rightcond = $rightcond->first; } $op = $rightcond; } return $self->maybe_parens($dep, $cx, $prec); } sub rv2gv_or_string { my($self,$op) = @_; if ($op->name eq "gv") { # could be open("open") or open("###") my($name,$quoted) = $self->stash_variable_name("", $self->gv_or_padgv($op)); $quoted ? $name : "*$name"; } else { $self->deparse($op, 6); } } sub listop { my $self = shift; my($op, $cx, $name, $kid, $nollafr) = @_; my(@exprs); my $parens = ($cx >= 5) || $self->{'parens'}; $kid ||= $op->first->sibling; # If there are no arguments, add final parentheses (or parenthesize the # whole thing if the llafr does not apply) to account for cases like # (return)+1 or setpgrp()+1. When the llafr does not apply, we use a # precedence of 6 (< comma), as "return, 1" does not need parentheses. if (null $kid) { return $nollafr ? $self->maybe_parens($self->keyword($name), $cx, 7) : $self->keyword($name) . '()' x (7 < $cx); } my $first; my $fullname = $self->keyword($name); my $proto = prototype("CORE::$name"); if ( ( (defined $proto && $proto =~ /^;?\*/) || $name eq 'select' # select(F) doesn't have a proto ) && $kid->name eq "rv2gv" && !($kid->private & OPpLVAL_INTRO) ) { $first = $self->rv2gv_or_string($kid->first); } else { $first = $self->deparse($kid, 6); } if ($name eq "chmod" && $first =~ /^\d+$/) { $first = sprintf("%#o", $first); } $first = "+$first" if not $parens and not $nollafr and substr($first, 0, 1) eq "("; push @exprs, $first; $kid = $kid->sibling; if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv" && !($kid->private & OPpLVAL_INTRO)) { push @exprs, $first = $self->rv2gv_or_string($kid->first); $kid = $kid->sibling; } for (; !null($kid); $kid = $kid->sibling) { push @exprs, $self->deparse($kid, 6); } if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) { return "$exprs[0] = $fullname" . ($parens ? "($exprs[0])" : " $exprs[0]"); } if ($parens && $nollafr) { return "($fullname " . join(", ", @exprs) . ")"; } elsif ($parens) { return "$fullname(" . join(", ", @exprs) . ")"; } else { return "$fullname " . join(", ", @exprs); } } sub pp_bless { listop(@_, "bless") } sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") } sub pp_substr { my ($self,$op,$cx) = @_; if ($op->private & OPpSUBSTR_REPL_FIRST) { return listop($self, $op, 7, "substr", $op->first->sibling->sibling) . " = " . $self->deparse($op->first->sibling, 7); } 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_sprintf { maybe_targmy(@_, \&listop, "sprintf") } sub pp_formline { listop(@_, "formline") } # see also deparse_format sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") } sub pp_unpack { listop(@_, "unpack") } sub pp_pack { listop(@_, "pack") } sub pp_join { maybe_targmy(@_, \&listop, "join") } sub pp_splice { listop(@_, "splice") } sub pp_push { maybe_targmy(@_, \&listop, "push") } sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") } sub pp_reverse { listop(@_, "reverse") } sub pp_warn { listop(@_, "warn") } sub pp_die { listop(@_, "die") } sub pp_return { listop(@_, "return", undef, 1) } # llafr does not apply sub pp_open { listop(@_, "open") } sub pp_pipe_op { listop(@_, "pipe") } sub pp_tie { listop(@_, "tie") } sub pp_binmode { listop(@_, "binmode") } sub pp_dbmopen { listop(@_, "dbmopen") } sub pp_sselect { listop(@_, "select") } sub pp_select { listop(@_, "select") } sub pp_read { listop(@_, "read") } sub pp_sysopen { listop(@_, "sysopen") } sub pp_sysseek { listop(@_, "sysseek") } sub pp_sysread { listop(@_, "sysread") } sub pp_syswrite { listop(@_, "syswrite") } sub pp_send { listop(@_, "send") } sub pp_recv { listop(@_, "recv") } sub pp_seek { listop(@_, "seek") } sub pp_fcntl { listop(@_, "fcntl") } sub pp_ioctl { listop(@_, "ioctl") } sub pp_flock { maybe_targmy(@_, \&listop, "flock") } sub pp_socket { listop(@_, "socket") } sub pp_sockpair { listop(@_, "socketpair") } sub pp_bind { listop(@_, "bind") } sub pp_connect { listop(@_, "connect") } sub pp_listen { listop(@_, "listen") } sub pp_accept { listop(@_, "accept") } sub pp_shutdown { listop(@_, "shutdown") } sub pp_gsockopt { listop(@_, "getsockopt") } sub pp_ssockopt { listop(@_, "setsockopt") } sub pp_chown { maybe_targmy(@_, \&listop, "chown") } sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") } sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") } sub pp_utime { maybe_targmy(@_, \&listop, "utime") } sub pp_rename { maybe_targmy(@_, \&listop, "rename") } sub pp_link { maybe_targmy(@_, \&listop, "link") } sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") } sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") } sub pp_open_dir { listop(@_, "opendir") } sub pp_seekdir { listop(@_, "seekdir") } sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") } sub pp_system { maybe_targmy(@_, \&indirop, "system") } sub pp_exec { maybe_targmy(@_, \&indirop, "exec") } sub pp_kill { maybe_targmy(@_, \&listop, "kill") } sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") } sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") } sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") } sub pp_shmget { listop(@_, "shmget") } sub pp_shmctl { listop(@_, "shmctl") } sub pp_shmread { listop(@_, "shmread") } sub pp_shmwrite { listop(@_, "shmwrite") } sub pp_msgget { listop(@_, "msgget") } sub pp_msgctl { listop(@_, "msgctl") } sub pp_msgsnd { listop(@_, "msgsnd") } sub pp_msgrcv { listop(@_, "msgrcv") } sub pp_semget { listop(@_, "semget") } sub pp_semctl { listop(@_, "semctl") } sub pp_semop { listop(@_, "semop") } sub pp_ghbyaddr { listop(@_, "gethostbyaddr") } sub pp_gnbyaddr { listop(@_, "getnetbyaddr") } sub pp_gpbynumber { listop(@_, "getprotobynumber") } sub pp_gsbyname { listop(@_, "getservbyname") } sub pp_gsbyport { listop(@_, "getservbyport") } sub pp_syscall { listop(@_, "syscall") } sub pp_glob { my $self = shift; my($op, $cx) = @_; my $kid = $op->first->sibling; # skip pushmark my $keyword = $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob'); my $text = $self->deparse($kid, $cx); return $cx >= 5 || $self->{'parens'} ? "$keyword($text)" : "$keyword $text"; } # Truncate is special because OPf_SPECIAL makes a bareword first arg # be a filehandle. This could probably be better fixed in the core # by moving the GV lookup into ck_truc. sub pp_truncate { my $self = shift; my($op, $cx) = @_; my(@exprs); my $parens = ($cx >= 5) || $self->{'parens'}; my $kid = $op->first->sibling; my $fh; if ($op->flags & OPf_SPECIAL) { # $kid is an OP_CONST $fh = $self->const_sv($kid)->PV; } else { $fh = $self->deparse($kid, 6); $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "("; } my $len = $self->deparse($kid->sibling, 6); my $name = $self->keyword('truncate'); if ($parens) { return "$name($fh, $len)"; } else { return "$name $fh, $len"; } } sub indirop { my $self = shift; my($op, $cx, $name) = @_; my($expr, @exprs); my $firstkid = my $kid = $op->first->sibling; my $indir = ""; if ($op->flags & OPf_STACKED) { $indir = $kid; $indir = $indir->first; # skip rv2gv if (is_scope($indir)) { $indir = "{" . $self->deparse($indir, 0) . "}"; $indir = "{;}" if $indir eq "{}"; } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) { $indir = $self->const_sv($indir)->PV; } else { $indir = $self->deparse($indir, 24); } $indir = $indir . " "; $kid = $kid->sibling; } if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) { $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} ' : '{$a <=> $b} '; } elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) { $indir = '{$b cmp $a} '; } for (; !null($kid); $kid = $kid->sibling) { $expr = $self->deparse($kid, !$indir && $kid == $firstkid && $name eq "sort" && $firstkid->name eq "entersub" ? 16 : 6); push @exprs, $expr; } my $name2; if ($name eq "sort" && $op->private & OPpSORT_REVERSE) { $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort'); } else { $name2 = $self->keyword($name) } if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) { return "$exprs[0] = $name2 $indir $exprs[0]"; } my $args = $indir . join(", ", @exprs); if ($indir ne "" && $name eq "sort") { # We don't want to say "sort(f 1, 2, 3)", since perl -w will # give bareword warnings in that case. Therefore if context # requires, we'll put parens around the outside "(sort f 1, 2, # 3)". Unfortunately, we'll currently think the parens are # necessary more often that they really are, because we don't # distinguish which side of an assignment we're on. if ($cx >= 5) { return "($name2 $args)"; } else { return "$name2 $args"; } } elsif ( !$indir && $name eq "sort" && !null($op->first->sibling) && $op->first->sibling->name eq 'entersub' ) { # We cannot say sort foo(bar), as foo will be interpreted as a # comparison routine. We have to say sort(...) in that case. return "$name2($args)"; } else { return length $args ? $self->maybe_parens_func($name2, $args, $cx, 5) : $name2 . '()' x (7 < $cx); } } sub pp_prtf { indirop(@_, "printf") } sub pp_print { indirop(@_, "print") } sub pp_say { indirop(@_, "say") } sub pp_sort { indirop(@_, "sort") } sub mapop { my $self = shift; my($op, $cx, $name) = @_; my($expr, @exprs); my $kid = $op->first; # this is the (map|grep)start $kid = $kid->first->sibling; # skip a pushmark my $code = $kid->first; # skip a null if (is_scope $code) { $code = "{" . $self->deparse($code, 0) . "} "; } else { $code = $self->deparse($code, 24); $code .= ", " if !null($kid->sibling); } $kid = $kid->sibling; for (; !null($kid); $kid = $kid->sibling) { $expr = $self->deparse($kid, 6); push @exprs, $expr if defined $expr; } return $self->maybe_parens_func($self->keyword($name), $code . join(", ", @exprs), $cx, 5); } sub pp_mapwhile { mapop(@_, "map") } sub pp_grepwhile { mapop(@_, "grep") } sub pp_mapstart { baseop(@_, "map") } sub pp_grepstart { baseop(@_, "grep") } my %uses_intro; BEGIN { @uses_intro{ eval { require B::Op_private } ? @{$B::Op_private::ops_using{OPpLVAL_INTRO}} : qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice hslice delete padsv padav padhv enteriter entersub padrange pushmark cond_expr refassign list) } = (); delete @uses_intro{qw( lvref lvrefslice lvavref entersub )}; } # 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'; my $lop; my $local = "either"; # could be local(...), my(...), state(...) or our(...) my $type; for ($lop = $kid; !null($lop); $lop = $lop->sibling) { my $lopname = $lop->name; my $loppriv = $lop->private; my $newtype; if ($lopname =~ /^pad[ash]v$/ && $loppriv & OPpLVAL_INTRO) { if ($loppriv & OPpPAD_STATE) { # state() ($local = "", last) if $local !~ /^(?:either|state)$/; $local = "state"; } else { # my() ($local = "", last) if $local !~ /^(?:either|my)$/; $local = "my"; } my $padname = $self->padname_sv($lop->targ); if ($padname->FLAGS & SVpad_TYPED) { $newtype = $padname->SvSTASH->NAME; } } elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/ && $loppriv & OPpOUR_INTRO or $lopname eq "null" && class($lop) eq 'UNOP' && $lop->first->name eq "gvsv" && $lop->first->private & OPpOUR_INTRO) { # our() my $newlocal = "local " x !!($loppriv & OPpLVAL_INTRO) . "our"; ($local = "", last) if $local ne 'either' && $local ne $newlocal; $local = $newlocal; my $funny = !$1 || $1 eq 's' ? '$' : $1 eq 'a' ? '@' : '%'; if (my $t = $self->find_our_type( $funny . $self->gv_or_padgv($lop->first)->NAME )) { $newtype = $t; } } elsif ($lopname ne 'undef' and !($loppriv & OPpLVAL_INTRO) || !exists $uses_intro{$lopname eq 'null' ? substr B::ppname($lop->targ), 3 : $lopname}) { $local = ""; # or not last; } elsif ($lopname ne "undef") { # local() ($local = "", last) if $local !~ /^(?:either|local)$/; $local = "local"; } if (defined $type && defined $newtype && $newtype ne $type) { $local = ''; last; } $type = $newtype; } $local = "" if $local eq "either"; # no point if it's all undefs $local &&= join ' ', map $self->keyword($_), split / /, $local; $local .= " $type " if $local && length $type; return $self->deparse($kid, $cx) if null $kid->sibling and not $local; for (; !null($kid); $kid = $kid->sibling) { if ($local) { if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") { $lop = $kid->first; } else { $lop = $kid; } $self->{'avoid_local'}{$$lop}++; $expr = $self->deparse($kid, 6); delete $self->{'avoid_local'}{$$lop}; } else { $expr = $self->deparse($kid, 6); } 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); } } sub is_ifelse_cont { my $op = shift; return ($op->name eq "null" and class($op) eq "UNOP" and $op->first->name =~ /^(and|cond_expr)$/ and is_scope($op->first->first->sibling)); } sub pp_cond_expr { my $self = shift; my($op, $cx) = @_; my $cond = $op->first; my $true = $cond->sibling; my $false = $true->sibling; my $cuddle = $self->{'cuddle'}; unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and (is_scope($false) || is_ifelse_cont($false)) and $self->{'expand'} < 7) { $cond = $self->deparse($cond, 8); $true = $self->deparse($true, 6); $false = $self->deparse($false, 8); return $self->maybe_parens("$cond ? $true : $false", $cx, 8); } $cond = $self->deparse($cond, 1); $true = $self->deparse($true, 0); my $head = $self->keyword("if") . " ($cond) {\n\t$true\n\b}"; my @elsifs; my $elsif; while (!null($false) and is_ifelse_cont($false)) { my $newop = $false->first; my $newcond = $newop->first; my $newtrue = $newcond->sibling; $false = $newtrue->sibling; # last in chain is OP_AND => no else if ($newcond->name eq "lineseq") { # lineseq to ensure correct line numbers in elsif() # Bug #37302 fixed by change #33710. $newcond = $newcond->first->sibling; } $newcond = $self->deparse($newcond, 1); $newtrue = $self->deparse($newtrue, 0); $elsif ||= $self->keyword("elsif"); push @elsifs, "$elsif ($newcond) {\n\t$newtrue\n\b}"; } if (!null($false)) { $false = $cuddle . $self->keyword("else") . " {\n\t" . $self->deparse($false, 0) . "\n\b}\cK"; } else { $false = "\cK"; } return $head . join($cuddle, "", @elsifs) . $false; } sub pp_once { my ($self, $op, $cx) = @_; my $cond = $op->first; my $true = $cond->sibling; my $ret = $self->deparse($true, $cx); $ret =~ s/^(\(?)\$/$1 . $self->keyword("state") . ' $'/e; $ret; } sub loop_common { my $self = shift; my($op, $cx, $init) = @_; my $enter = $op->first; my $kid = $enter->sibling; local(@$self{qw'curstash warnings hints hinthash'}) = @$self{qw'curstash warnings hints hinthash'}; my $head = ""; my $bare = 0; my $body; my $cond = undef; my $name; if ($kid->name eq "lineseq") { # bare or infinite loop if ($kid->last->name eq "unstack") { # infinite $head = "while (1) "; # Can't use for(;;) if there's a continue $cond = ""; } else { $bare = 1; } $body = $kid; } elsif ($enter->name eq "enteriter") { # foreach my $ary = $enter->first->sibling; # first was pushmark my $var = $ary->sibling; if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) { # "reverse" was optimised away $ary = listop($self, $ary->first->sibling, 1, 'reverse'); } elsif ($enter->flags & OPf_STACKED and not null $ary->first->sibling->sibling) { $ary = $self->deparse($ary->first->sibling, 9) . " .. " . $self->deparse($ary->first->sibling->sibling, 9); } else { $ary = $self->deparse($ary, 1); } if (null $var) { $var = $self->pp_padsv($enter, 1, 1); } elsif ($var->name eq "rv2gv") { $var = $self->pp_rv2sv($var, 1); if ($enter->private & OPpOUR_INTRO) { # our declarations don't have package names $var =~ s/^(.).*::/$1/; $var = "our $var"; } } elsif ($var->name eq "gv") { $var = "\$" . $self->deparse($var, 1); } else { $var = $self->deparse($var, 1); } $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER if (!is_state $body->first and $body->first->name !~ /^(?:stub|leave|scope)$/) { confess unless $var eq '$_'; $body = $body->first; return $self->deparse($body, 2) . " " . $self->keyword("foreach") . " ($ary)"; } $head = "foreach $var ($ary) "; } elsif ($kid->name eq "null") { # while/until $kid = $kid->first; $name = {"and" => "while", "or" => "until"}->{$kid->name}; $cond = $kid->first; $body = $kid->first->sibling; } elsif ($kid->name eq "stub") { # bare and empty return "{;}"; # {} could be a hashref } # If there isn't a continue block, then the next pointer for the loop # will point to the unstack, which is kid's last child, except # in a bare loop, when it will point to the leaveloop. When neither of # these conditions hold, then the second-to-last child is the continue # block (or the last in a bare loop). my $cont_start = $enter->nextop; my $cont; my $precond; my $postcond; if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) { if ($bare) { $cont = $body->last; } else { $cont = $body->first; while (!null($cont->sibling->sibling)) { $cont = $cont->sibling; } } my $state = $body->first; my $cuddle = $self->{'cuddle'}; my @states; for (; $$state != $$cont; $state = $state->sibling) { push @states, $state; } $body = $self->lineseq(undef, 0, @states); if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) { $precond = "for ($init; "; $postcond = "; " . $self->deparse($cont, 1) .") "; $cont = "\cK"; } else { $cont = $cuddle . "continue {\n\t" . $self->deparse($cont, 0) . "\n\b}\cK"; } } else { return "" if !defined $body; if (length $init) { $precond = "for ($init; "; $postcond = ";) "; } $cont = "\cK"; $body = $self->deparse($body, 0); } if ($precond) { # for(;;) $cond &&= $name eq 'until' ? listop($self, undef, 1, "not", $cond->first) : $self->deparse($cond, 1); $head = "$precond$cond$postcond"; } if ($name && !$head) { ref $cond and $cond = $self->deparse($cond, 1); $head = "$name ($cond) "; } $head =~ s/^(for(?:each)?|while|until)/$self->keyword($1)/e; $body =~ s/;?$/;\n/; return $head . "{\n\t" . $body . "\b}" . $cont; } sub pp_leaveloop { shift->loop_common(@_, "") } sub for_loop { my $self = shift; my($op, $cx) = @_; my $init = $self->deparse($op, 1); my $s = $op->sibling; my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling; return $self->loop_common($ll, $cx, $init); } sub pp_leavetry { my $self = shift; return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}"; } sub _op_is_or_was { my ($op, $expect_type) = @_; my $type = $op->type; return($type == $expect_type || ($type == OP_NULL && $op->targ == $expect_type)); } 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; } elsif (class ($op) eq "COP") { return &pp_nextstate; } elsif ($op->first->name eq 'pushmark' or $op->first->name eq 'null' && $op->first->targ == OP_PUSHMARK && _op_is_or_was($op, OP_LIST)) { return $self->pp_list($op, $cx); } elsif ($op->first->name eq "enter") { return $self->pp_leave($op, $cx); } elsif ($op->first->name eq "leave") { return $self->pp_leave($op->first, $cx); } elsif ($op->first->name eq "scope") { return $self->pp_scope($op->first, $cx); } elsif ($op->targ == OP_STRINGIFY) { return $self->dquote($op, $cx); } elsif ($op->targ == OP_GLOB) { return $self->pp_glob( $op->first # entersub ->first # ex-list ->first # pushmark ->sibling, # glob $cx ); } elsif (!null($op->first->sibling) and $op->first->sibling->name eq "readline" and $op->first->sibling->flags & OPf_STACKED) { return $self->maybe_parens($self->deparse($op->first, 7) . " = " . $self->deparse($op->first->sibling, 7), $cx, 7); } elsif (!null($op->first->sibling) and $op->first->sibling->name =~ /^transr?\z/ and $op->first->sibling->flags & OPf_STACKED) { return $self->maybe_parens($self->deparse($op->first, 20) . " =~ " . $self->deparse($op->first->sibling, 20), $cx, 20); } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) { return ($self->lex_in_scope("&do") ? "CORE::do" : "do") . " {\n\t". $self->deparse($op->first, $cx) ."\n\b};"; } elsif (!null($op->first->sibling) and $op->first->sibling->name eq "null" and class($op->first->sibling) eq "UNOP" and $op->first->sibling->first->flags & OPf_STACKED and $op->first->sibling->first->name eq "rcatline") { return $self->maybe_parens($self->deparse($op->first, 18) . " .= " . $self->deparse($op->first->sibling, 18), $cx, 18); } else { return $self->deparse($op->first, $cx); } } sub padname { my $self = shift; my $targ = shift; return $self->padname_sv($targ)->PVX; } sub padany { my $self = shift; my $op = shift; return substr($self->padname($op->targ), 1); # skip $/@/% } sub pp_padsv { my $self = shift; my($op, $cx, $forbid_parens) = @_; my $targ = $op->targ; return $self->maybe_my($op, $cx, $self->padname($targ), $self->padname_sv($targ), $forbid_parens); } sub pp_padav { pp_padsv(@_) } # prepend 'keys' where its been optimised away, with suitable handling # of CORE:: and parens sub add_keys_keyword { my ($self, $str, $cx) = @_; $str = $self->maybe_parens($str, $cx, 16); # 'keys %h' versus 'keys(%h)' $str = " $str" unless $str =~ /^\(/; return $self->keyword("keys") . $str; } sub pp_padhv { my ($self, $op, $cx) = @_; my $str = pp_padsv(@_); # with OPpPADHV_ISKEYS the keys op is optimised away, except # in scalar context the old op is kept (but not executed) so its targ # can be used. if ( ($op->private & OPpPADHV_ISKEYS) && !(($op->flags & OPf_WANT) == OPf_WANT_SCALAR)) { $str = $self->add_keys_keyword($str, $cx); } $str; } sub gv_or_padgv { my $self = shift; my $op = shift; if (class($op) eq "PADOP") { return $self->padval($op->padix); } else { # class($op) eq "SVOP" return $op->gv; } } sub pp_gvsv { my $self = shift; my($op, $cx) = @_; my $gv = $self->gv_or_padgv($op); return $self->maybe_local($op, $cx, $self->stash_variable("\$", $self->gv_name($gv), $cx)); } sub pp_gv { my $self = shift; my($op, $cx) = @_; my $gv = $self->gv_or_padgv($op); return $self->maybe_qualify("", $self->gv_name($gv)); } sub pp_aelemfast_lex { my $self = shift; my($op, $cx) = @_; my $name = $self->padname($op->targ); $name =~ s/^@/\$/; my $i = $op->private; $i -= 256 if $i > 127; return $name . "[$i]"; } sub pp_aelemfast { my $self = shift; my($op, $cx) = @_; # optimised PADAV, pre 5.15 return $self->pp_aelemfast_lex(@_) if ($op->flags & OPf_SPECIAL); my $gv = $self->gv_or_padgv($op); my($name,$quoted) = $self->stash_variable_name('@',$gv); $name = $quoted ? "$name->" : '$' . $name; my $i = $op->private; $i -= 256 if $i > 127; return $name . "[$i]"; } sub rv2x { my $self = shift; my($op, $cx, $type) = @_; if (class($op) eq 'NULL' || !$op->can("first")) { carp("Unexpected op in pp_rv2x"); return 'XXX'; } my $kid = $op->first; if ($kid->name eq "gv") { 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/) { # "$$+" isn't a legal way to write the scalar dereference # of $+, since the lexer can't tell you aren't trying to # do something like "$$ + 1" to get one more than your # PID. Either "${$+}" or "$${+}" are workable # disambiguations, but if the programmer did the former, # they'd be in the "else" clause below rather than here. # It's not clear if this should somehow be unified with # the code in dq and re_dq that also adds lexer # disambiguation braces. $str = '$' . "{$1}"; #' } return $type . $str; } else { return $type . "{" . $self->deparse($kid, 0) . "}"; } } sub pp_rv2sv { 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) = @_; my $kid = $op->first; if ($kid->name eq "padav") { return $self->maybe_local($op, $cx, '$#' . $self->padany($kid)); } else { 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, '$#')); } } } # skip down to the old, ex-rv2cv sub pp_rv2cv { my ($self, $op, $cx) = @_; if (!null($op->first) && $op->first->name eq 'null' && $op->first->targ == OP_LIST) { return $self->rv2x($op->first->first->sibling, $cx, "&") } else { return $self->rv2x($op, $cx, "") } } sub list_const { my $self = shift; my($cx, @list) = @_; my @a = map $self->const($_, 6), @list; if (@a == 0) { return "()"; } elsif (@a == 1) { return $a[0]; } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) { # collapse (-1,0,1,2) into (-1..2) my ($s, $e) = @a[0,-1]; my $i = $s; return $self->maybe_parens("$s..$e", $cx, 9) unless grep $i++ != $_, @a; } return $self->maybe_parens(join(", ", @a), $cx, 6); } sub pp_rv2av { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; if ($kid->name eq "const") { # constant list my $av = $self->const_sv($kid); return $self->list_const($cx, $av->ARRAY); } else { return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@")); } } sub is_subscriptable { my $op = shift; if ($op->name =~ /^([ahg]elem|multideref$)/) { return 1; } elsif ($op->name eq "entersub") { my $kid = $op->first; return 0 unless null $kid->sibling; $kid = $kid->first; $kid = $kid->sibling until null $kid->sibling; return 0 if is_scope($kid); $kid = $kid->first; return 0 if $kid->name eq "gv" || $kid->name eq "padcv"; return 0 if is_scalar($kid); return is_subscriptable($kid); } else { return 0; } } sub elem_or_slice_array_name { my $self = shift; my ($array, $left, $padname, $allow_arrow) = @_; if ($array->name eq $padname) { return $self->padany($array); } elsif (is_scope($array)) { # ${expr}[0] return "{" . $self->deparse($array, 0) . "}"; } elsif ($array->name eq "gv") { ($array, my $quoted) = $self->stash_variable_name( $left eq '[' ? '@' : '%', $self->gv_or_padgv($array) ); if (!$allow_arrow && $quoted) { # This cannot happen. die "Invalid variable name $array for slice"; } return $quoted ? "$array->" : $array; } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ... return $self->deparse($array, 24); } else { return undef; } } sub elem_or_slice_single_index { my $self = shift; my ($idx) = @_; $idx = $self->deparse($idx, 1); # Outer parens in an array index will confuse perl # if we're interpolating in a regular expression, i.e. # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/ # # If $self->{parens}, then an initial '(' will # definitely be paired with a final ')'. If # !$self->{parens}, the misleading parens won't # have been added in the first place. # # [You might think that we could get "(...)...(...)" # where the initial and final parens do not match # each other. But we can't, because the above would # only happen if there's an infix binop between the # two pairs of parens, and *that* means that the whole # expression would be parenthesized as well.] # $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'}; # Hash-element braces will autoquote a bareword inside themselves. # We need to make sure that C<$hash{warn()}> doesn't come out as # C<$hash{warn}>, which has a quite different meaning. Currently # B::Deparse will always quote strings, even if the string was a # bareword in the original (i.e. the OPpCONST_BARE flag is ignored # for constant strings.) So we can cheat slightly here - if we see # a bareword, we know that it is supposed to be a function call. # $idx =~ s/^([A-Za-z_]\w*)$/$1()/; return $idx; } sub elem { my $self = shift; my ($op, $cx, $left, $right, $padname) = @_; my($array, $idx) = ($op->first, $op->first->sibling); $idx = $self->elem_or_slice_single_index($idx); unless ($array->name eq $padname) { # Maybe this has been fixed $array = $array->first; # skip rv2av (or ex-rv2av in _53+) } if (my $array_name=$self->elem_or_slice_array_name ($array, $left, $padname, 1)) { return ($array_name =~ /->\z/ ? $array_name : $array_name eq '#' ? '${#}' : "\$" . $array_name) . $left . $idx . $right; } else { # $x[20][3]{hi} or expr->[20] my $arrow = is_subscriptable($array) ? "" : "->"; return $self->deparse($array, 24) . $arrow . $left . $idx . $right; } } # a simplified version of elem_or_slice_array_name() # for the use of pp_multideref sub multideref_var_name { my $self = shift; my ($gv, $is_hash) = @_; my ($name, $quoted) = $self->stash_variable_name( $is_hash ? '%' : '@', $gv); return $quoted ? "$name->" : $name eq '#' ? '${#}' # avoid ${#}[1] => $#[1] : '$' . $name; } # deparse an OP_MULTICONCAT. If $in_dq is 1, we're within # a double-quoted string, so for example. # "abc\Qdef$x\Ebar" # might get compiled as # multiconcat("abc", metaquote(multiconcat("def", $x)), "bar") # and the inner multiconcat should be deparsed as C<def$x> rather than # the normal C<def . $x> # Ditto if $in_dq is 2, handle qr/...\Qdef$x\E.../. sub do_multiconcat { my $self = shift; my($op, $cx, $in_dq) = @_; my $kid; my @kids; my $assign; my $append; my $lhs = ""; for ($kid = $op->first; !null $kid; $kid = $kid->sibling) { # skip the consts and/or padsv we've optimised away push @kids, $kid unless $kid->type == OP_NULL && ( $kid->targ == OP_PADSV || $kid->targ == OP_CONST || $kid->targ == OP_PUSHMARK); } $append = ($op->private & OPpMULTICONCAT_APPEND); if ($op->private & OPpTARGET_MY) { # '$lex = ...' or '$lex .= ....' or 'my $lex = ' $lhs = $self->padname($op->targ); $lhs = "my $lhs" if ($op->private & OPpLVAL_INTRO); $assign = 1; } elsif ($op->flags & OPf_STACKED) { # 'expr = ...' or 'expr .= ....' my $expr = $append ? shift(@kids) : pop(@kids); $lhs = $self->deparse($expr, 7); $assign = 1; } if ($assign) { $lhs .= $append ? ' .= ' : ' = '; } my ($nargs, $const_str, @const_lens) = $op->aux_list($self->{curcv}); my @consts; my $i = 0; for (@const_lens) { if ($_ == -1) { push @consts, undef; } else { push @consts, substr($const_str, $i, $_); my @args; $i += $_; } } my $rhs = ""; if ( $in_dq || (($op->private & OPpMULTICONCAT_STRINGIFY) && !$self->{'unquote'})) { # "foo=$foo bar=$bar " my $not_first; while (@consts) { 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) = @_; my $text = ""; if ($op->private & OPpMULTIDEREF_EXISTS) { $text = $self->keyword("exists"). " "; } elsif ($op->private & OPpMULTIDEREF_DELETE) { $text = $self->keyword("delete"). " "; } elsif ($op->private & OPpLVAL_INTRO) { $text = $self->keyword("local"). " "; } if ($op->first && ($op->first->flags & OPf_KIDS)) { # arbitrary initial expression, e.g. f(1,2,3)->[...] my $expr = $self->deparse($op->first, 24); # stop "exists (expr)->{...}" being interpreted as #"(exists (expr))->{...}" $expr = "+$expr" if $expr =~ /^\(/; $text .= $expr; } my @items = $op->aux_list($self->{curcv}); my $actions = shift @items; my $is_hash; my $derefs = 0; while (1) { if (($actions & MDEREF_ACTION_MASK) == MDEREF_reload) { $actions = shift @items; next; } $is_hash = ( ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_pop_rv2hv_helem || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvsv_vivify_rv2hv_helem || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padsv_vivify_rv2hv_helem || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_vivify_rv2hv_helem || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem ); if ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_padav_aelem || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem) { $derefs = 1; $text .= '$' . substr($self->padname(shift @items), 1); } elsif ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_gvav_aelem || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem) { $derefs = 1; $text .= $self->multideref_var_name(shift @items, $is_hash); } else { if ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_padsv_vivify_rv2av_aelem || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padsv_vivify_rv2hv_helem) { $text .= $self->padname(shift @items); } elsif ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_gvsv_vivify_rv2av_aelem || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvsv_vivify_rv2hv_helem) { $text .= $self->multideref_var_name(shift @items, $is_hash); } elsif ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_pop_rv2av_aelem || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_pop_rv2hv_helem) { if ( ($op->flags & OPf_KIDS) && ( _op_is_or_was($op->first, OP_RV2AV) || _op_is_or_was($op->first, OP_RV2HV)) && ($op->first->flags & OPf_KIDS) && ( _op_is_or_was($op->first->first, OP_AELEM) || _op_is_or_was($op->first->first, OP_HELEM)) ) { $derefs++; } } $text .= '->' if !$derefs++; } if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_none) { last; } $text .= $is_hash ? '{' : '['; if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_const) { my $key = shift @items; if ($is_hash) { $text .= $self->const($key, $cx); } else { $text .= $key; } } elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_padsv) { $text .= $self->padname(shift @items); } elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_gvsv) { $text .= '$' . ($self->stash_variable_name('$', shift @items))[0]; } $text .= $is_hash ? '}' : ']'; if ($actions & MDEREF_FLAG_last) { last; } $actions >>= MDEREF_SHIFT; } return $text; } sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) } sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) } sub pp_gelem { my $self = shift; my($op, $cx) = @_; my($glob, $part) = ($op->first, $op->last); $glob = $glob->first; # skip rv2gv $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug 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}"; } sub slice { my $self = shift; my ($op, $cx, $left, $right, $regname, $padname) = @_; my $last; my(@elems, $kid, $array, $list); if (class($op) eq "LISTOP") { $last = $op->last; } else { # ex-hslice inside delete() for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {} $last = $kid; } $array = $last; $array = $array->first if $array->name eq $regname or $array->name eq "null"; $array = $self->elem_or_slice_array_name($array,$left,$padname,0); $kid = $op->first->sibling; # skip pushmark if ($kid->name eq "list") { $kid = $kid->first->sibling; # skip list, pushmark for (; !null $kid; $kid = $kid->sibling) { push @elems, $self->deparse($kid, 6); } $list = join(", ", @elems); } else { $list = $self->elem_or_slice_single_index($kid); } my $lead = ( _op_is_or_was($op, OP_KVHSLICE) || _op_is_or_was($op, OP_KVASLICE)) ? '%' : '@'; return $lead . $array . $left . $list . $right; } sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) } sub pp_kvaslice { slice(@_, "[", "]", "rv2av", "padav") } sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) } sub pp_kvhslice { slice(@_, "{", "}", "rv2hv", "padhv") } sub pp_lslice { my $self = shift; my($op, $cx) = @_; my $idx = $op->first; my $list = $op->last; my(@elems, $kid); $list = $self->deparse($list, 1); $idx = $self->deparse($idx, 1); return "($list)" . "[$idx]"; } sub want_scalar { my $op = shift; return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR; } sub want_list { my $op = shift; return ($op->flags & OPf_WANT) == OPf_WANT_LIST; } sub _method { my $self = shift; my($op, $cx) = @_; my $kid = $op->first->sibling; # skip pushmark my($meth, $obj, @exprs); if ($kid->name eq "list" and want_list $kid) { # When an indirect object isn't a bareword but the args are in # parens, the parens aren't part of the method syntax (the LLAFR # doesn't apply), but they make a list with OPf_PARENS set that # doesn't get flattened by the append_elem that adds the method, # making a (object, arg1, arg2, ...) list where the object # usually is. This can be distinguished from # '($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an # object) because in the later the list is in scalar context # as the left side of -> always is, while in the former # the list is in list context as method arguments always are. # (Good thing there aren't method prototypes!) $meth = $kid->sibling; $kid = $kid->first->sibling; # skip pushmark $obj = $kid; $kid = $kid->sibling; for (; not null $kid; $kid = $kid->sibling) { push @exprs, $kid; } } else { $obj = $kid; $kid = $kid->sibling; for (; !null ($kid->sibling) && $kid->name!~/^method(?:_named)?\z/; $kid = $kid->sibling) { push @exprs, $kid } $meth = $kid; } if ($meth->name eq "method_named") { $meth = $self->meth_sv($meth)->PV; } elsif ($meth->name eq "method_super") { $meth = "SUPER::".$self->meth_sv($meth)->PV; } elsif ($meth->name eq "method_redir") { $meth = $self->meth_rclass_sv($meth)->PV.'::'.$self->meth_sv($meth)->PV; } elsif ($meth->name eq "method_redir_super") { $meth = $self->meth_rclass_sv($meth)->PV.'::SUPER::'. $self->meth_sv($meth)->PV; } else { $meth = $meth->first; if ($meth->name eq "const") { # As of 5.005_58, this case is probably obsoleted by the # method_named case above $meth = $self->const_sv($meth)->PV; # needs to be bare } } return { method => $meth, variable_method => ref($meth), object => $obj, args => \@exprs }, $cx; } # compat function only sub method { my $self = shift; my $info = $self->_method(@_); return $self->e_method( $self->_method(@_) ); } sub e_method { my ($self, $info, $cx) = @_; my $obj = $self->deparse($info->{object}, 24); my $meth = $info->{method}; $meth = $self->deparse($meth, 1) if $info->{variable_method}; my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} ); if ($info->{object}->name eq 'scope' && want_list $info->{object}) { # method { $object } # This must be deparsed this way to preserve list context # of $object. my $need_paren = $cx >= 6; return '(' x $need_paren . $meth . substr($obj,2) # chop off the "do" . " $args" . ')' x $need_paren; } my $kid = $obj . "->" . $meth; if (length $args) { return $kid . "(" . $args . ")"; # parens mandatory } else { return $kid; } } # returns "&" if the prototype doesn't match the args, # or ("", $args_after_prototype_demunging) if it does. sub check_proto { my $self = shift; return "&" if $self->{'noproto'}; my($proto, @args) = @_; my($arg, $real); my $doneok = 0; my @reals; # An unbackslashed @ or % gobbles up the rest of the args 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/; $proto =~ s/^\s*//; while ($proto) { $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;|)\s*//; my $chr = $1; if ($chr eq "") { return "&" if @args; } elsif ($chr eq ";") { $doneok = 1; } elsif ($chr eq "@" or $chr eq "%") { push @reals, map($self->deparse($_, 6), @args); @args = (); } else { $arg = shift @args; last unless $arg; if ($chr eq "\$" || $chr eq "_") { if (want_scalar $arg) { push @reals, $self->deparse($arg, 6); } else { return "&"; } } elsif ($chr eq "&") { if ($arg->name =~ /^(s?refgen|undef)$/) { push @reals, $self->deparse($arg, 6); } else { return "&"; } } elsif ($chr eq "*") { if ($arg->name =~ /^s?refgen$/ and $arg->first->first->name eq "rv2gv") { $real = $arg->first->first; # skip refgen, null if ($real->first->name eq "gv") { push @reals, $self->deparse($real, 6); } else { push @reals, $self->deparse($real->first, 6); } } else { return "&"; } } elsif (substr($chr, 0, 1) eq "\\") { $chr =~ tr/\\[]//d; if ($arg->name =~ /^s?refgen$/ and !null($real = $arg->first) and ($chr =~ /\$/ && is_scalar($real->first) or ($chr =~ /@/ && class($real->first->sibling) ne 'NULL' && $real->first->sibling->name =~ /^(rv2|pad)av$/) or ($chr =~ /%/ && class($real->first->sibling) ne 'NULL' && $real->first->sibling->name =~ /^(rv2|pad)hv$/) #or ($chr =~ /&/ # This doesn't work # && $real->first->name eq "rv2cv") or ($chr =~ /\*/ && $real->first->name eq "rv2gv"))) { push @reals, $self->deparse($real, 6); } else { return "&"; } } } } return "&" if $proto and !$doneok; # too few args and no ';' return "&" if @args; # too many args return ("", join ", ", @reals); } sub retscalar { my $name = $_[0]->name; # XXX There has to be a better way of doing this scalar-op check. # Currently PL_opargs is not exposed. if ($name eq 'null') { $name = substr B::ppname($_[0]->targ), 3 } $name =~ /^(?:scalar|pushmark|wantarray|const|gvsv|gv|padsv|rv2gv |rv2sv|av2arylen|anoncode|prototype|srefgen|ref|bless |regcmaybe|regcreset|regcomp|qr|subst|substcont|trans |transr|sassign|chop|schop|chomp|schomp|defined|undef |study|pos|preinc|i_preinc|predec|i_predec|postinc |i_postinc|postdec|i_postdec|pow|multiply|i_multiply |divide|i_divide|modulo|i_modulo|add|i_add|subtract |i_subtract|concat|multiconcat|stringify|left_shift|right_shift|lt |i_lt|gt|i_gt|le|i_le|ge|i_ge|eq|i_eq|ne|i_ne|ncmp|i_ncmp |slt|sgt|sle|sge|seq|sne|scmp|[sn]?bit_(?:and|x?or)|negate |i_negate|not|[sn]?complement|smartmatch|atan2|sin|cos |rand|srand|exp|log|sqrt|int|hex|oct|abs|length|substr |vec|index|rindex|sprintf|formline|ord|chr|crypt|ucfirst |lcfirst|uc|lc|quotemeta|aelemfast|aelem|exists|helem |pack|join|anonlist|anonhash|push|pop|shift|unshift|xor |andassign|orassign|dorassign|warn|die|reset|nextstate |dbstate|unstack|last|next|redo|dump|goto|exit|open|close |pipe_op|fileno|umask|binmode|tie|untie|tied|dbmopen |dbmclose|select|getc|read|enterwrite|prtf|print|say |sysopen|sysseek|sysread|syswrite|eof|tell|seek|truncate |fcntl|ioctl|flock|send|recv|socket|sockpair|bind|connect |listen|accept|shutdown|gsockopt|ssockopt|getsockname |getpeername|ftrread|ftrwrite|ftrexec|fteread|ftewrite |fteexec|ftis|ftsize|ftmtime|ftatime|ftctime|ftrowned |fteowned|ftzero|ftsock|ftchr|ftblk|ftfile|ftdir|ftpipe |ftsuid|ftsgid|ftsvtx|ftlink|fttty|fttext|ftbinary|chdir |chown|chroot|unlink|chmod|utime|rename|link|symlink |readlink|mkdir|rmdir|open_dir|telldir|seekdir|rewinddir |closedir|fork|wait|waitpid|system|exec|kill|getppid |getpgrp|setpgrp|getpriority|setpriority|time|alarm|sleep |shmget|shmctl|shmread|shmwrite|msgget|msgctl|msgsnd |msgrcv|semop|semget|semctl|hintseval|shostent|snetent |sprotoent|sservent|ehostent|enetent|eprotoent|eservent |spwent|epwent|sgrent|egrent|getlogin|syscall|lock|runcv |fc)\z/x } sub pp_entersub { my $self = shift; my($op, $cx) = @_; return $self->e_method($self->_method($op, $cx)) unless null $op->first->sibling; my $prefix = ""; my $amper = ""; my($kid, @exprs); if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) { $prefix = "do "; } elsif ($op->private & OPpENTERSUB_AMPER) { $amper = "&"; } $kid = $op->first; $kid = $kid->first->sibling; # skip ex-list, pushmark for (; not null $kid->sibling; $kid = $kid->sibling) { push @exprs, $kid; } my $simple = 0; my $proto = undef; my $lexical; if (is_scope($kid)) { $amper = "&"; $kid = "{" . $self->deparse($kid, 0) . "}"; } elsif ($kid->first->name eq "gv") { my $gv = $self->gv_or_padgv($kid->first); my $cv; if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL" || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') { $proto = $cv->PV if $cv->FLAGS & SVf_POK; } $simple = 1; # only calls of named functions can be prototyped $kid = $self->maybe_qualify("!", $self->gv_name($gv)); my $fq; # Fully qualify any sub name that conflicts with a lexical. if ($self->lex_in_scope("&$kid") || $self->lex_in_scope("&$kid", 1)) { $fq++; } elsif (!$amper) { if ($kid eq 'main::') { $kid = '::'; } else { if ($kid !~ /::/ && $kid ne 'x') { # Fully qualify any sub name that is also a keyword. While # we could check the import flag, we cannot guarantee that # the code deparsed so far would set that flag, so we qual- # ify the names regardless of importation. if (exists $feature_keywords{$kid}) { $fq++ if $self->feature_enabled($kid); } elsif (do { local $@; local $SIG{__DIE__}; eval { () = prototype "CORE::$kid"; 1 } }) { $fq++ } } if ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) { $kid = single_delim("q", "'", $kid, $self) . '->'; } } } $fq and substr $kid, 0, 0, = $self->{'curstash'}.'::'; } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') { $amper = "&"; $kid = $self->deparse($kid, 24); } else { $prefix = ""; my $grandkid = $kid->first; my $arrow = ($lexical = $grandkid->name eq "padcv") || is_subscriptable($grandkid) ? "" : "->"; $kid = $self->deparse($kid, 24) . $arrow; if ($lexical) { my $padlist = $self->{'curcv'}->PADLIST; my $padoff = $grandkid->targ; my $padname = $padlist->ARRAYelt(0)->ARRAYelt($padoff); my $protocv = $padname->FLAGS & SVpad_STATE ? $padlist->ARRAYelt(1)->ARRAYelt($padoff) : $padname->PROTOCV; if ($protocv->FLAGS & SVf_POK) { $proto = $protocv->PV } $simple = 1; } } # Doesn't matter how many prototypes there are, if # they haven't happened yet! my $declared = $lexical || exists $self->{'subs_declared'}{$kid}; if (not $declared and $self->{'in_coderef2text'}) { no strict 'refs'; no warnings 'uninitialized'; $declared = ( defined &{ ${$self->{'curstash'}."::"}{$kid} } && !exists $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid} && defined prototype $self->{'curstash'}."::".$kid ); } if (!$declared && defined($proto)) { # Avoid "too early to check prototype" warning ($amper, $proto) = ('&'); } my $args; my $listargs = 1; if ($declared and defined $proto and not $amper) { ($amper, $args) = $self->check_proto($proto, @exprs); $listargs = $amper; } if ($listargs) { $args = join(", ", map( ($_->flags & OPf_WANT) == OPf_WANT_SCALAR && !retscalar($_) ? $self->maybe_parens_unop('scalar', $_, 6) : $self->deparse($_, 6), @exprs )); } if ($prefix or $amper) { if ($kid eq '&') { $kid = "{$kid}" } # &{&} cannot be written as && if ($op->flags & OPf_STACKED) { return $prefix . $amper . $kid . "(" . $args . ")"; } else { return $prefix . $amper. $kid; } } else { # It's a syntax error to call CORE::GLOBAL::foo with a prefix, # so it must have been translated from a keyword call. Translate # it back. $kid =~ s/^CORE::GLOBAL:://; my $dproto = defined($proto) ? $proto : "undefined"; my $scalar_proto = $dproto =~ /^;*(?:[\$*_+]|\\.|\\\[[^]]\])\z/; if (!$declared) { return "$kid(" . $args . ")"; } elsif ($dproto =~ /^\s*\z/) { return $kid; } elsif ($scalar_proto and is_scalar($exprs[0])) { # is_scalar is an excessively conservative test here: # really, we should be comparing to the precedence of the # top operator of $exprs[0] (ala unop()), but that would # take some major code restructuring to do right. return $self->maybe_parens_func($kid, $args, $cx, 16); } elsif (not $scalar_proto and defined($proto) || $simple) { #' return $self->maybe_parens_func($kid, $args, $cx, 5); } else { return "$kid(" . $args . ")"; } } } sub pp_enterwrite { unop(@_, "write") } # escape things that cause interpolation in double quotes, # but not character escapes sub uninterp { my($str) = @_; $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g; return $str; } { my $bal; BEGIN { use re "eval"; # Matches any string which is balanced with respect to {braces} $bal = qr( (?: [^\\{}] | \\\\ | \\[{}] | \{(??{$bal})\} )* )x; } # the same, but treat $|, $), $( and $ at the end of the string differently # and leave comments unmangled for the sake of /x and (?x). sub re_uninterp { my($str) = @_; $str =~ s/ ( ^|\G # $1 | [^\\] ) ( # $2 (?:\\\\)* ) ( # $3 ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks) | \#[^\n]* # (skip over comments) ) | [\$\@] (?!\||\)|\(|$|\s) | \\[uUlLQE] ) /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg; return $str; } } # character escapes, but not delimiters that might need to be escaped sub escape_str { # ASCII, UTF8 my($str) = @_; $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; $str =~ s/\a/\\a/g; # $str =~ s/\cH/\\b/g; # \b means something different in a regex; and \cH # isn't a backspace in EBCDIC $str =~ s/\t/\\t/g; $str =~ s/\n/\\n/g; $str =~ s/\e/\\e/g; $str =~ s/\f/\\f/g; $str =~ s/\r/\\r/g; $str =~ s/([\cA-\cZ])/'\\c' . $unctrl{$1}/ge; $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/age; return $str; } # For regexes. Leave whitespace unmangled in case of /x or (?x). sub escape_re { my($str) = @_; $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; $str =~ s/([[:^print:]])/ ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/age; $str =~ s/\n/\n\f/g; return $str; } # Don't do this for regexen sub unback { my($str) = @_; $str =~ s/\\/\\\\/g; return $str; } # Remove backslashes which precede literal control characters, # to avoid creating ambiguity when we escape the latter. # # Don't remove a backslash from escaped whitespace: where the T represents # a literal tab character, /T/x is not equivalent to /\T/x sub re_unback { my($str) = @_; # the insane complexity here is due to the behaviour of "\c\" $str =~ s/ # 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; } sub balanced_delim { my($str) = @_; my @str = split //, $str; my($ar, $open, $close, $fail, $c, $cnt, $last_bs); for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) { ($open, $close) = @$ar; $fail = 0; $cnt = 0; $last_bs = 0; for $c (@str) { if ($c eq $open) { $fail = 1 if $last_bs; $cnt++; } elsif ($c eq $close) { $fail = 1 if $last_bs; $cnt--; if ($cnt < 0) { # qq()() isn't ")(" $fail = 1; last; } } $last_bs = $c eq '\\'; } $fail = 1 if $cnt != 0; return ($open, "$open$str$close") if not $fail; } return ("", $str); } sub single_delim { my($q, $default, $str, $self) = @_; return "$default$str$default" if $default and index($str, $default) == -1; my $coreq = $self->keyword($q); # maybe CORE::q if ($q ne 'qr') { (my $succeed, $str) = balanced_delim($str); return "$coreq$str" if $succeed; } for my $delim ('/', '"', '#') { return "$coreq$delim" . $str . $delim if index($str, $delim) == -1; } if ($default) { $str =~ s/$default/\\$default/g; return "$default$str$default"; } else { $str =~ s[/][\\/]g; return "$coreq/$str/"; } } my $max_prec; BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); } # Split a floating point number into an integer mantissa and a binary # exponent. Assumes you've already made sure the number isn't zero or # some weird infinity or NaN. sub split_float { my($f) = @_; my $exponent = 0; if ($f == int($f)) { while ($f % 2 == 0) { $f /= 2; $exponent++; } } else { while ($f != int($f)) { $f *= 2; $exponent--; } } my $mantissa = sprintf("%.0f", $f); return ($mantissa, $exponent); } # suitably single- or double-quote a literal constant string sub quoted_const_str { my ($self, $str) =@_; if ($str =~ /[[:^print:]]/a) { return single_delim("qq", '"', uninterp(escape_str unback $str), $self); } else { return single_delim("q", "'", unback($str), $self); } } sub const { my $self = shift; my($sv, $cx) = @_; if ($self->{'use_dumper'}) { return $self->const_dumper($sv, $cx); } if (class($sv) eq "SPECIAL") { # sv_undef, sv_yes, sv_no return $$sv == 3 ? $self->maybe_parens("!1", $cx, 21) : ('undef', '1')[$$sv-1]; } if (class($sv) eq "NULL") { return 'undef'; } # convert a version object into the "v1.2.3" string in its V magic if ($sv->FLAGS & SVs_RMG) { for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) { return $mg->PTR if $mg->TYPE eq 'V'; } } if ($sv->FLAGS & SVf_IOK) { my $str = $sv->int_value; $str = $self->maybe_parens($str, $cx, 21) if $str < 0; return $str; } elsif ($sv->FLAGS & SVf_NOK) { my $nv = $sv->NV; if ($nv == 0) { if (pack("F", $nv) eq pack("F", 0)) { # positive zero return "0"; } else { # negative zero return $self->maybe_parens("-.0", $cx, 21); } } elsif (1/$nv == 0) { if ($nv > 0) { # positive infinity return $self->maybe_parens("9**9**9", $cx, 22); } else { # negative infinity return $self->maybe_parens("-9**9**9", $cx, 21); } } elsif ($nv != $nv) { # NaN if (pack("F", $nv) eq pack("F", sin(9**9**9))) { # the normal kind return "sin(9**9**9)"; } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) { # the inverted kind return $self->maybe_parens("-sin(9**9**9)", $cx, 21); } else { # some other kind my $hex = unpack("h*", pack("F", $nv)); return qq'unpack("F", pack("h*", "$hex"))'; } } # first, try the default stringification my $str = "$nv"; if ($str != $nv) { # failing that, try using more precision $str = sprintf("%.${max_prec}g", $nv); # if (pack("F", $str) ne pack("F", $nv)) { if ($str != $nv) { # not representable in decimal with whatever sprintf() # and atof() Perl is using here. my($mant, $exp) = split_float($nv); return $self->maybe_parens("$mant * 2**$exp", $cx, 19); } } $str = $self->maybe_parens($str, $cx, 21) if $nv < 0; return $str; } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) { my $ref = $sv->RV; my $class = class($ref); if ($class eq "AV") { return "[" . $self->list_const(2, $ref->ARRAY) . "]"; } elsif ($class eq "HV") { my %hash = $ref->ARRAY; my @elts; for my $k (sort keys %hash) { push @elts, "$k => " . $self->const($hash{$k}, 6); } return "{" . join(", ", @elts) . "}"; } elsif ($class eq "CV") { no overloading; if ($self->{curcv} && $self->{curcv}->object_2svref == $ref->object_2svref) { return $self->keyword("__SUB__"); } return "sub " . $self->deparse_sub($ref); } if ($class ne 'SPECIAL' and $ref->FLAGS & SVs_SMG) { for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) { if ($mg->TYPE eq 'r') { my $re = re_uninterp(escape_re(re_unback($mg->precomp))); return single_delim("qr", "", $re, $self); } } } my $const = $self->const($ref, 20); if ($self->{in_subst_repl} && $const =~ /^[0-9]/) { $const = "($const)"; } return $self->maybe_parens("\\$const", $cx, 20); } elsif ($sv->FLAGS & SVf_POK) { my $str = $sv->PV; return $self->quoted_const_str($str); } else { return "undef"; } } sub const_dumper { my $self = shift; my($sv, $cx) = @_; my $ref = $sv->object_2svref(); my $dumper = Data::Dumper->new([$$ref], ['$v']); $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1); my $str = $dumper->Dump(); if ($str =~ /^\$v/) { return '${my ' . $str . ' \$v}'; } else { return $str; } } sub const_sv { my $self = shift; my $op = shift; my $sv = $op->sv; # the constant could be in the pad (under useithreads) $sv = $self->padval($op->targ) unless $$sv; return $sv; } sub meth_sv { my $self = shift; my $op = shift; my $sv = $op->meth_sv; # the constant could be in the pad (under useithreads) $sv = $self->padval($op->targ) unless $$sv; return $sv; } sub meth_rclass_sv { my $self = shift; my $op = shift; my $sv = $op->rclass; # the constant could be in the pad (under useithreads) $sv = $self->padval($sv) unless ref $sv; return $sv; } sub pp_const { my $self = shift; my($op, $cx) = @_; # if ($op->private & OPpCONST_BARE) { # trouble with '=>' autoquoting # return $self->const_sv($op)->PV; # } my $sv = $self->const_sv($op); 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; my $type = $op->name; if ($type eq "const") { return uninterp(escape_str(unback($self->const_sv($op)->as_string))); } elsif ($type eq "concat") { 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") { return '\L' . $self->dq($op->first->sibling) . '\E'; } elsif ($type eq "ucfirst") { return '\u' . $self->dq($op->first->sibling); } elsif ($type eq "lcfirst") { return '\l' . $self->dq($op->first->sibling); } elsif ($type eq "quotemeta") { return '\Q' . $self->dq($op->first->sibling) . '\E'; } elsif ($type eq "fc") { return '\F' . $self->dq($op->first->sibling) . '\E'; } elsif ($type eq "join") { return $self->deparse($op->last, 26); # was join($", @ary) } else { return $self->deparse($op, 26); } } sub pp_backtick { my $self = shift; my($op, $cx) = @_; # skip pushmark if it exists (readpipe() vs ``) my $child = $op->first->sibling->isa('B::NULL') ? $op->first : $op->first->sibling; if ($self->pure_string($child)) { return single_delim("qx", '`', $self->dq($child, 1), $self); } unop($self, @_, "readpipe"); } sub dquote { my $self = shift; my($op, $cx) = @_; my $kid = $op->first->sibling; # skip ex-stringify, pushmark return $self->deparse($kid, $cx) if $self->{'unquote'}; $self->maybe_targmy($kid, $cx, sub {single_delim("qq", '"', $self->dq($_[1]), $self)}); } # OP_STRINGIFY is a listop, but it only ever has one arg sub pp_stringify { my ($self, $op, $cx) = @_; my $kid = $op->first->sibling; while ($kid->name eq 'null' && !null($kid->first)) { $kid = $kid->first; } if ($kid->name =~ /^(?:const|padsv|rv2sv|av2arylen|gvsv|multideref |aelemfast(?:_lex)?|[ah]elem|join|concat)\z/x) { maybe_targmy(@_, \&dquote); } else { # Actually an optimised join. my $result = listop(@_,"join"); $result =~ s/join([( ])/join$1$self->{'ex_const'}, /; $result; } } # tr/// and s/// (and tr[][], tr[]//, tr###, etc) # note that tr(from)/to/ is OK, but not tr/from/(to) sub double_delim { my($from, $to) = @_; my($succeed, $delim); if ($from !~ m[/] and $to !~ m[/]) { return "/$from/$to/"; } elsif (($succeed, $from) = balanced_delim($from) and $succeed) { if (($succeed, $to) = balanced_delim($to) and $succeed) { return "$from$to"; } else { for $delim ('/', '"', '#') { # note no "'" -- s''' is special return "$from$delim$to$delim" if index($to, $delim) == -1; } $to =~ s[/][\\/]g; return "$from/$to/"; } } else { for $delim ('/', '"', '#') { # note no ' return "$delim$from$delim$to$delim" if index($to . $from, $delim) == -1; } $from =~ s[/][\\/]g; $to =~ s[/][\\/]g; return "/$from/$to/"; } } # Escape a characrter. # Only used by tr///, so backslashes hyphens sub pchr { # ASCII my($n) = @_; if ($n == ord '\\') { return '\\\\'; } elsif ($n == ord "-") { return "\\-"; } elsif (utf8::native_to_unicode($n) >= utf8::native_to_unicode(ord(' ')) and utf8::native_to_unicode($n) <= utf8::native_to_unicode(ord('~'))) { # I'm presuming a regex is not ok here, otherwise we could have used # /[[:print:]]/a to get here return chr($n); } elsif ($n == ord "\a") { return '\\a'; } elsif ($n == ord "\b") { return '\\b'; } elsif ($n == ord "\t") { return '\\t'; } elsif ($n == ord "\n") { return '\\n'; } elsif ($n == ord "\e") { return '\\e'; } elsif ($n == ord "\f") { return '\\f'; } elsif ($n == ord "\r") { return '\\r'; } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) { 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) = (""); for ($c = 0; $c < @chars; $c++) { $tr = $chars[$c]; $str .= pchr($tr); if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and $chars[$c + 2] == $tr + 2) { for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++) {} $str .= "-"; $str .= pchr($chars[$c]); } } return $str; } sub tr_decode_byte { my($table, $flags) = @_; 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) { $tr = $table[ord "-"]; $table[ord "-"] = -1; if ($tr >= 0) { @from = ord("-"); @to = $tr; } else { # -2 ==> delete $delhyphen = 1; } } for ($c = 0; $c < @table; $c++) { $tr = $table[$c]; if ($tr >= 0) { push @from, $c; push @to, $tr; } elsif ($tr == -2) { push @delfrom, $c; } } @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; for ($c = 0; $c < 256; $c++) { push @newfrom, $c unless $from{$c}; } @from = @newfrom; } unless ($flags & OPpTRANS_DELETE || !@to) { pop @to while $#to and $to[$#to] == $to[$#to -1]; } my($from, $to); $from = collapse(@from); $to = collapse(@to); $from .= "-" if $delhyphen; return ($from, $to); } sub tr_chr { my $x = shift; if ($x == ord "-") { return "\\-"; } elsif ($x == ord "\\") { return "\\\\"; } else { return chr $x; } } sub tr_invmap { my ($invlist_ref, $map_ref) = @_; my $infinity = ~0 >> 1; # IV_MAX my $from = ""; my $to = ""; for my $i (0.. @$invlist_ref - 1) { my $this_from = $invlist_ref->[$i]; my $map = $map_ref->[$i]; my $upper = ($i < @$invlist_ref - 1) ? $invlist_ref->[$i+1] : $infinity; my $range = $upper - $this_from - 1; if (DEBUG) { print STDERR "i=$i, from=$this_from, upper=$upper, range=$range\n"; } next if $map == ~0; next if $map == ~0 - 1; $from .= tr_chr($this_from); $to .= tr_chr($map); next if $range == 0; # Single code point if ($range == 1) { # Adjacent code points $from .= tr_chr($this_from + 1); $to .= tr_chr($map + 1); } elsif ($upper != $infinity) { $from .= "-" . tr_chr($this_from + $range); $to .= "-" . tr_chr($map + $range); } else { $from .= "-INFTY"; $to .= "-INFTY"; } } return ($from, $to); } sub tr_decode_utf8 { my($tr_av, $flags) = @_; printf STDERR "flags=0x%x\n", $flags if DEBUG; my $invlist = $tr_av->ARRAYelt(0); my @invlist = unpack("J*", $invlist->PV); my @map = unpack("J*", $tr_av->ARRAYelt(1)->PV); if (DEBUG) { for my $i (0 .. @invlist - 1) { printf STDERR "[%d]\t%x\t", $i, $invlist[$i]; my $map = $map[$i]; if ($map == ~0) { print STDERR "TR_UNMAPPED\n"; } elsif ($map == ~0 - 1) { print STDERR "TR_SPECIAL\n"; } else { printf STDERR "%x\n", $map; } } } my ($from, $to) = tr_invmap(\@invlist, \@map); if ($flags & OPpTRANS_COMPLEMENT) { shift @map; pop @invlist; my $throw_away; ($from, $throw_away) = tr_invmap(\@invlist, \@map); } if (DEBUG) { print STDERR "Returning ", escape_str($from), "/", escape_str($to), "\n"; } return (escape_str($from), escape_str($to)); } sub pp_trans { my $self = shift; my($op, $cx, $morflags) = @_; my($from, $to); my $class = class($op); my $priv_flags = $op->private; if ($class eq "PVOP") { ($from, $to) = tr_decode_byte($op->pv, $priv_flags); } elsif ($class eq "PADOP") { ($from, $to) = tr_decode_utf8($self->padval($op->padix), $priv_flags); } else { # class($op) eq "SVOP" ($from, $to) = tr_decode_utf8($op->sv, $priv_flags); } my $flags = ""; $flags .= "c" if $priv_flags & OPpTRANS_COMPLEMENT; $flags .= "d" if $priv_flags & OPpTRANS_DELETE; $to = "" if $from eq $to and $flags eq ""; $flags .= "s" if $priv_flags & OPpTRANS_SQUASH; $flags .= $morflags if defined $morflags; my $ret = $self->keyword("tr") . double_delim($from, $to) . $flags; if (my $targ = $op->targ) { return $self->maybe_parens($self->padname($targ) . " =~ $ret", $cx, 20); } return $ret; } sub pp_transr { 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) = @_; ($last =~ /^[A-Z\\\^\[\]_?]/ && $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc || ($last =~ /^[{\[\w_]/ && $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/); return $first . $last; } # Like dq(), but different sub re_dq { my $self = shift; my ($op) = @_; my $type = $op->name; if ($type eq "const") { my $unbacked = re_unback($self->const_sv($op)->as_string); return re_uninterp(escape_re($unbacked)); } elsif ($type eq "concat") { 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") { return '\L' . $self->re_dq($op->first->sibling) . '\E'; } elsif ($type eq "ucfirst") { return '\u' . $self->re_dq($op->first->sibling); } elsif ($type eq "lcfirst") { return '\l' . $self->re_dq($op->first->sibling); } elsif ($type eq "quotemeta") { return '\Q' . $self->re_dq($op->first->sibling) . '\E'; } elsif ($type eq "fc") { return '\F' . $self->re_dq($op->first->sibling) . '\E'; } elsif ($type eq "join") { return $self->deparse($op->last, 26); # was join($", @ary) } else { my $ret = $self->deparse($op, 26); $ret =~ s/^\$([(|)])\z/\${$1}/ # $( $| $) need braces or $ret =~ s/^\@([-+])\z/\@{$1}/; # @- @+ need braces return $ret; } } sub pure_string { my ($self, $op) = @_; return 0 if null $op; my $type = $op->name; if ($type eq 'const' || $type eq 'av2arylen') { return 1; } elsif ($type =~ /^(?:[ul]c(first)?|fc)$/ || $type eq 'quotemeta') { return $self->pure_string($op->first->sibling); } elsif ($type eq 'join') { my $join_op = $op->first->sibling; # Skip pushmark return 0 unless $join_op->name eq 'null' && $join_op->targ == OP_RV2SV; my $gvop = $join_op->first; return 0 unless $gvop->name eq 'gvsv'; return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop)); return 0 unless ${$join_op->sibling} eq ${$op->last}; return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/; } elsif ($type eq 'concat') { 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; } elsif ($type eq "null" and $op->can('first') and not null $op->first) { my $first = $op->first; return 1 if $first->name eq "multideref"; return 1 if $first->name eq "aelemfast_lex"; if ( $first->name eq "null" and $first->can('first') and not null $first->first and $first->first->name eq "aelemfast" ) { return 1; } } return 0; } sub code_list { my ($self,$op,$cv) = @_; # localise stuff relating to the current sub $cv and local($self->{'curcv'}) = $cv, local($self->{'curcvlex'}), local(@$self{qw'curstash warnings hints hinthash curcop'}) = @$self{qw'curstash warnings hints hinthash curcop'}; my $re; for ($op = $op->first->sibling; !null($op); $op = $op->sibling) { if ($op->name eq 'null' and $op->flags & OPf_SPECIAL) { my $scope = $op->first; # 0 context (last arg to scopeop) means statement context, so # the contents of the block will not be wrapped in do{...}. my $block = scopeop($scope->first->name eq "enter", $self, $scope, 0); # next op is the source code of the block $op = $op->sibling; $re .= ($self->const_sv($op)->PV =~ m|^(\(\?\??\{)|)[0]; my $multiline = $block =~ /\n/; $re .= $multiline ? "\n\t" : ' '; $re .= $block; $re .= $multiline ? "\n\b})" : " })"; } else { $re = re_dq_disambiguate($re, $self->re_dq($op)); } } $re; } sub regcomp { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; $kid = $kid->first if $kid->name eq "regcmaybe"; $kid = $kid->first if $kid->name eq "regcreset"; my $kname = $kid->name; if ($kname eq "null" and !null($kid->first) and $kid->first->name eq 'pushmark') { my $str = ''; $kid = $kid->first->sibling; while (!null($kid)) { my $first = $str; my $last = $self->re_dq($kid); $str = re_dq_disambiguate($first, $last); $kid = $kid->sibling; } return $str, 1; } return ($self->re_dq($kid), 1) if $kname =~ /^(?:rv2|pad)av/ or $self->pure_string($kid); return ($self->deparse($kid, $cx), 0); } sub pp_regcomp { my ($self, $op, $cx) = @_; return (($self->regcomp($op, $cx, 0))[0]); } sub re_flags { my ($self, $op) = @_; my $flags = ''; my $pmflags = $op->pmflags; if (!$pmflags) { my $re = $op->pmregexp; if ($$re) { $pmflags = $re->compflags; } } $flags .= "g" if $pmflags & PMf_GLOBAL; $flags .= "i" if $pmflags & PMf_FOLD; $flags .= "m" if $pmflags & PMf_MULTILINE; $flags .= "o" if $pmflags & PMf_KEEP; $flags .= "s" if $pmflags & PMf_SINGLELINE; $flags .= "x" if $pmflags & PMf_EXTENDED; $flags .= "x" if $pmflags & PMf_EXTENDED_MORE; $flags .= "p" if $pmflags & PMf_KEEPCOPY; $flags .= "n" if $pmflags & PMf_NOCAPTURE; if (my $charset = $pmflags & PMf_CHARSET) { # Hardcoding this is fragile, but B does not yet export the # constants we need. $flags .= qw(d l u a aa)[$charset >> 7] } # The /d flag is indicated by 0; only show it if necessary. elsif ($self->{hinthash} and $self->{hinthash}{reflags_charset} || $self->{hinthash}{feature_unicode} or $self->{hints} & $feature::hint_mask && ($self->{hints} & $feature::hint_mask) != $feature::hint_mask && $self->{hints} & $feature::hint_uni8bit ) { $flags .= 'd'; } $flags; } # osmic acid -- see osmium tetroxide my %matchwords; map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs', 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic', 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi', 'soup', 'soupmix'); # When deparsing a regular expression with code blocks, we have to look in # various places to find the blocks. # # For qr/(?{...})/ without interpolation, the CV is under $qr->qr_anoncv # and the code list (list of blocks and constants, maybe vars) is under # $cv->ROOT->first->code_list: # ./perl -Ilib -MB -e 'use O "Concise", B::svref_2object(sub {qr/(?{die})/})->ROOT->first->first->sibling->pmregexp->qr_anoncv->object_2svref' # # For qr/$a(?{...})/ with interpolation, the code list is more accessible, # under $pmop->code_list, but the $cv is something you have to dig for in # the regcomp op’s kids: # ./perl -Ilib -mO=Concise -e 'qr/$a(?{die})/' # # For m// and split //, things are much simpler. There is no CV. The code # list is under $pmop->code_list. sub matchop { my $self = shift; my($op, $cx, $name, $delim) = @_; my $kid = $op->first; my ($binop, $var, $re) = ("", "", ""); if ($op->name ne 'split' && $op->flags & OPf_STACKED) { $binop = 1; $var = $self->deparse($kid, 20); $kid = $kid->sibling; } # not $name; $name will be 'm' for both match and split elsif ($op->name eq 'match' and my $targ = $op->targ) { $binop = 1; $var = $self->padname($targ); } my $quote = 1; my $pmflags = $op->pmflags; my $rhs_bound_to_defsv; my ($cv, $bregexp); my $have_kid = !null $kid; # Check for code blocks first if (not null my $code_list = $op->code_list) { $re = $self->code_list($code_list, $op->name eq 'qr' ? $self->padval( $kid->first # ex-list ->first # pushmark ->sibling # entersub ->first # ex-list ->first # pushmark ->sibling # srefgen ->first # ex-list ->first # anoncode ->targ ) : undef); } elsif (${$bregexp = $op->pmregexp} && ${$cv = $bregexp->qr_anoncv}) { my $patop = $cv->ROOT # leavesub ->first # qr ->code_list;# list $re = $self->code_list($patop, $cv); } elsif (!$have_kid) { $re = re_uninterp(escape_re(re_unback($op->precomp))); } elsif ($kid->name ne 'regcomp') { 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); } if ($have_kid and $kid->name eq 'regcomp') { my $matchop = $kid->first; if ($matchop->name eq 'regcreset') { $matchop = $matchop->first; } if ($matchop->name =~ /^(?:match|transr?|subst)\z/ && $matchop->flags & OPf_SPECIAL) { $rhs_bound_to_defsv = 1; } } my $flags = ""; $flags .= "c" if $pmflags & PMf_CONTINUE; $flags .= $self->re_flags($op); $flags = join '', sort split //, $flags; $flags = $matchwords{$flags} if $matchwords{$flags}; if ($pmflags & PMf_ONCE) { # only one kind of delimiter works here $re =~ s/\?/\\?/g; $re = $self->keyword("m") . "?$re?"; # explicit 'm' is required } elsif ($quote) { $re = single_delim($name, $delim, $re, $self); } $re = $re . $flags if $quote; if ($binop) { return $self->maybe_parens( $rhs_bound_to_defsv ? "$var =~ (\$_ =~ $re)" : "$var =~ $re", $cx, 20 ); } else { return $re; } } sub pp_match { matchop(@_, "m", "/") } sub pp_qr { matchop(@_, "qr", "") } sub pp_runcv { unop(@_, "__SUB__"); } sub pp_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); } 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 ($op->private & OPpLVAL_INTRO) { $ary = $op->private & OPpSPLIT_LEX ? "my $ary" : "local $ary"; } } } # handle special case of split(), and split(' ') that compiles to /\s+/ $exprs[0] = q{' '} if ($op->reflags // 0) & RXf_SKIPWHITE(); $expr = "split(" . join(", ", @exprs) . ")"; if ($ary) { return $self->maybe_parens("$ary = $expr", $cx, 7); } else { return $expr; } } # oxime -- any of various compounds obtained chiefly by the action of # hydroxylamine on aldehydes and ketones and characterized by the # bivalent grouping C=NOH [Webster's Tenth] my %substwords; map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em', 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me', 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem', 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi', 'rogue', 'sir', 'rise', 'smore', 'more', 'seer', 'rome', 'gore', 'grim', 'grime', 'or', 'rose', 'rosie'); sub pp_subst { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; my($binop, $var, $re, $repl) = ("", "", "", ""); if ($op->flags & OPf_STACKED) { $binop = 1; $var = $self->deparse($kid, 20); $kid = $kid->sibling; } elsif (my $targ = $op->targ) { $binop = 1; $var = $self->padname($targ); } my $flags = ""; my $pmflags = $op->pmflags; if (null($op->pmreplroot)) { $repl = $kid; $kid = $kid->sibling; } else { $repl = $op->pmreplroot->first; # skip substcont } while ($repl->name eq "entereval") { $repl = $repl->first; $flags .= "e"; } { local $self->{in_subst_repl} = 1; if ($pmflags & PMf_EVAL) { $repl = $self->deparse($repl->first, 0); } else { $repl = $self->dq($repl); } } if (not null my $code_list = $op->code_list) { $re = $self->code_list($code_list); } elsif (null $kid) { $re = re_uninterp(escape_re(re_unback($op->precomp))); } else { ($re) = $self->regcomp($kid, 1); } $flags .= "r" if $pmflags & PMf_NONDESTRUCT; $flags .= "e" if $pmflags & PMf_EVAL; $flags .= $self->re_flags($op); $flags = join '', sort split //, $flags; $flags = $substwords{$flags} if $substwords{$flags}; my $core_s = $self->keyword("s"); # maybe CORE::s if ($binop) { return $self->maybe_parens("$var =~ $core_s" . double_delim($re, $repl) . $flags, $cx, 20); } else { return "$core_s". double_delim($re, $repl) . $flags; } } sub is_lexical_subs { my (@ops) = shift; for my $op (@ops) { return 0 if $op->name !~ /\A(?:introcv|clonecv)\z/; } return 1; } # Pretend these two ops do not exist. The perl parser adds them to the # beginning of any block containing my-sub declarations, whereas we handle # the subs in pad_subs and next_todo. *pp_clonecv = *pp_introcv; sub pp_introcv { my $self = shift; my($op, $cx) = @_; # For now, deparsing doesn't worry about the distinction between introcv # and clonecv, so pretend this op doesn't exist: return ''; } sub pp_padcv { my $self = shift; my($op, $cx) = @_; return $self->padany($op); } my %lvref_funnies = ( OPpLVREF_SV, => '$', OPpLVREF_AV, => '@', OPpLVREF_HV, => '%', OPpLVREF_CV, => '&', ); sub pp_refassign { my ($self, $op, $cx) = @_; my $left; if ($op->private & OPpLVREF_ELEM) { $left = $op->first->sibling; $left = maybe_local(@_, elem($self, $left, undef, $left->targ == OP_AELEM ? qw([ ] padav) : qw({ } padhv))); } elsif ($op->flags & OPf_STACKED) { $left = maybe_local(@_, $lvref_funnies{$op->private & OPpLVREF_TYPE} . $self->deparse($op->first->sibling)); } else { $left = &pp_padsv; } my $right = $self->deparse_binop_right($op, $op->first, 7); return $self->maybe_parens("\\$left = $right", $cx, 7); } sub pp_lvref { my ($self, $op, $cx) = @_; my $code; if ($op->private & OPpLVREF_ELEM) { $code = $op->first->name =~ /av\z/ ? &pp_aelem : &pp_helem; } elsif ($op->flags & OPf_STACKED) { $code = maybe_local(@_, $lvref_funnies{$op->private & OPpLVREF_TYPE} . $self->deparse($op->first)); } else { $code = &pp_padsv; } "\\$code"; } sub pp_lvrefslice { my ($self, $op, $cx) = @_; '\\' . ($op->last->name =~ /av\z/ ? &pp_aslice : &pp_hslice); } sub pp_lvavref { my ($self, $op, $cx) = @_; '\\(' . ($op->flags & OPf_STACKED ? maybe_local(@_, rv2x(@_, "\@")) : &pp_padsv) . ')' } 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__ =head1 NAME B::Deparse - Perl compiler backend to produce perl code =head1 SYNOPSIS B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>] [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl> =head1 DESCRIPTION B::Deparse is a backend module for the Perl compiler that generates perl source code, based on the internal compiled structure that perl itself creates after parsing a program. The output of B::Deparse won't be exactly the same as the original source, since perl doesn't keep track of comments or whitespace, and there isn't a one-to-one correspondence between perl's syntactical constructions and their compiled form, but it will often be close. When you use the B<-p> option, the output also includes parentheses even when they are not required by precedence, which can make it easy to see if perl is parsing your expressions the way you intended. While B::Deparse goes to some lengths to try to figure out what your original program was doing, some parts of the language can still trip it up; it still fails even on some parts of Perl's own test suite. If you encounter a failure other than the most common ones described in the BUGS section below, you can help contribute to B::Deparse's ongoing development by submitting a bug report with a small example. =head1 OPTIONS As with all compiler backend options, these must follow directly after the '-MO=Deparse', separated by a comma but not any white space. =over 4 =item B<-d> Output data values (when they appear as constants) using Data::Dumper. Without this option, B::Deparse will use some simple routines of its own for the same purpose. Currently, Data::Dumper is better for some kinds of data (such as complex structures with sharing and self-reference) while the built-in routines are better for others (such as odd floating-point values). =item B<-f>I<FILE> Normally, B::Deparse deparses the main code of a program, and all the subs defined in the same file. To include subs defined in other files, pass the B<-f> option with the filename. You can pass the B<-f> option several times, to include more than one secondary file. (Most of the time you don't want to use it at all.) You can also use this option to include subs which are defined in the scope of a B<#line> directive with two parameters. =item B<-l> Add '#line' declarations to the output based on the line and file locations of the original code. =item B<-p> Print extra parentheses. Without this option, B::Deparse includes parentheses in its output only when they are needed, based on the structure of your program. With B<-p>, it uses parentheses (almost) whenever they would be legal. This can be useful if you are used to LISP, or if you want to see how perl parses your input. If you say if ($var & 0x7f == 65) {print "Gimme an A!"} print ($which ? $a : $b), "\n"; $name = $ENV{USER} or "Bob"; C<B::Deparse,-p> will print if (($var & 0)) { print('Gimme an A!') }; (print(($which ? $a : $b)), '???'); (($name = $ENV{'USER'}) or '???') which probably isn't what you intended (the C<'???'> is a sign that perl optimized away a constant value). =item B<-P> Disable prototype checking. With this option, all function calls are deparsed as if no prototype was defined for them. In other words, perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x' will print sub foo (\@) { 1; } &foo(\@x); making clear how the parameters are actually passed to C<foo>. =item B<-q> Expand double-quoted strings into the corresponding combinations of concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For instance, print print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!"; as print 'Hello, ' . $world . ', ' . join($", @ladies) . ', ' . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!'); Note that the expanded form represents the way perl handles such constructions internally -- this option actually turns off the reverse translation that B::Deparse usually does. On the other hand, note that C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value of $y into a string before doing the assignment. =item B<-s>I<LETTERS> Tweak the style of B::Deparse's output. The letters should follow directly after the 's', with no space or punctuation. The following options are available: =over 4 =item B<C> Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print if (...) { ... } else { ... } instead of if (...) { ... } else { ... } The default is not to cuddle. =item B<i>I<NUMBER> Indent lines by multiples of I<NUMBER> columns. The default is 4 columns. =item B<T> Use tabs for each 8 columns of indent. The default is to use only spaces. For instance, if the style options are B<-si4T>, a line that's indented 3 times will be preceded by one tab and four spaces; if the options were B<-si8T>, the same line would be preceded by three tabs. =item B<v>I<STRING>B<.> Print I<STRING> for the value of a constant that can't be determined because it was optimized away (mnemonic: this happens when a constant is used in B<v>oid context). The end of the string is marked by a period. The string should be a valid perl expression, generally a constant. Note that unless it's a number, it probably needs to be quoted, and on a command line quotes need to be protected from the shell. Some conventional values include 0, 1, 42, '', 'foo', and 'Useless use of constant omitted' (which may need to be B<-sv"'Useless use of constant omitted'."> or something similar depending on your shell). The default is '???'. If you're using B::Deparse on a module or other file that's require'd, you shouldn't use a value that evaluates to false, since the customary true constant at the end of a module will be in void context when the file is compiled as a main program. =back =item B<-x>I<LEVEL> Expand conventional syntax constructions into equivalent ones that expose their internal operation. I<LEVEL> should be a digit, with higher values meaning more expansion. As with B<-q>, this actually involves turning off special cases in B::Deparse's normal operations. If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent while loops with continue blocks; for instance for ($i = 0; $i < 10; ++$i) { print $i; } turns into $i = 0; while ($i < 10) { print $i; } continue { ++$i } Note that in a few cases this translation can't be perfectly carried back into the source code -- if the loop's initializer declares a my variable, for instance, it won't have the correct scope outside of the loop. If I<LEVEL> is at least 5, C<use> declarations will be translated into C<BEGIN> blocks containing calls to C<require> and C<import>; for instance, use strict 'refs'; turns into sub BEGIN { require strict; do { 'strict'->import('refs') }; } If I<LEVEL> is at least 7, C<if> statements will be translated into equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance print 'hi' if $nice; if ($nice) { print 'hi'; } if ($nice) { print 'hi'; } else { print 'bye'; } turns into $nice and print 'hi'; $nice and do { print 'hi' }; $nice ? do { print 'hi' } : do { print 'bye' }; Long sequences of elsifs will turn into nested ternary operators, which B::Deparse doesn't know how to indent nicely. =back =head1 USING B::Deparse AS A MODULE =head2 Synopsis use B::Deparse; $deparse = B::Deparse->new("-p", "-sC"); $body = $deparse->coderef2text(\&func); eval "sub func $body"; # the inverse operation =head2 Description B::Deparse can also be used on a sub-by-sub basis from other perl programs. =head2 new $deparse = B::Deparse->new(OPTIONS) Create an object to store the state of a deparsing operation and any options. The options are the same as those that can be given on the command line (see L</OPTIONS>); options that are separated by commas after B<-MO=Deparse> should be given as separate strings. =head2 ambient_pragmas $deparse->ambient_pragmas(strict => 'all', '$[' => $[); The compilation of a subroutine can be affected by a few compiler directives, B<pragmas>. These are: =over 4 =item * use strict; =item * use warnings; =item * Assigning to the special variable $[ =item * use integer; =item * use bytes; =item * use utf8; =item * use re; =back Ordinarily, if you use B::Deparse on a subroutine which has been compiled in the presence of one or more of these pragmas, the output will include statements to turn on the appropriate directives. So if you then compile the code returned by coderef2text, it will behave the same way as the subroutine which you deparsed. However, you may know that you intend to use the results in a particular context, where some pragmas are already in scope. In this case, you use the B<ambient_pragmas> method to describe the assumptions you wish to make. Not all of the options currently have any useful effect. See L</BUGS> for more details. The parameters it accepts are: =over 4 =item strict Takes a string, possibly containing several values separated by whitespace. The special values "all" and "none" mean what you'd expect. $deparse->ambient_pragmas(strict => 'subs refs'); =item $[ Takes a number, the value of the array base $[. Obsolete: cannot be non-zero. =item bytes =item utf8 =item integer If the value is true, then the appropriate pragma is assumed to be in the ambient scope, otherwise not. =item re Takes a string, possibly containing a whitespace-separated list of values. The values "all" and "none" are special. It's also permissible to pass an array reference here. $deparser->ambient_pragmas(re => 'eval'); =item warnings Takes a string, possibly containing a whitespace-separated list of values. The values "all" and "none" are special, again. It's also permissible to pass an array reference here. $deparser->ambient_pragmas(warnings => [qw[void io]]); If one of the values is the string "FATAL", then all the warnings in that list will be considered fatal, just as with the B<warnings> pragma itself. Should you need to specify that some warnings are fatal, and others are merely enabled, you can pass the B<warnings> parameter twice: $deparser->ambient_pragmas( warnings => 'all', warnings => [FATAL => qw/void io/], ); See L<warnings> for more information about lexical warnings. =item hint_bits =item warning_bits These two parameters are used to specify the ambient pragmas in the format used by the special variables $^H and ${^WARNING_BITS}. They exist principally so that you can write code like: { my ($hint_bits, $warning_bits); BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})} $deparser->ambient_pragmas ( hint_bits => $hint_bits, warning_bits => $warning_bits, '$[' => 0 + $[ ); } which specifies that the ambient pragmas are exactly those which are in scope at the point of calling. =item %^H This parameter is used to specify the ambient pragmas which are stored in the special hash %^H. =back =head2 coderef2text $body = $deparse->coderef2text(\&func) $body = $deparse->coderef2text(sub ($$) { ... }) Return source code for the body of a subroutine (a block, optionally preceded by a prototype in parens), given a reference to the sub. Because a subroutine can have no names, or more than one name, this method doesn't return a complete subroutine definition -- if you want to eval the result, you should prepend "sub subname ", or "sub " for an anonymous function constructor. Unless the sub was defined in the main:: package, the code will include a package declaration. =head1 BUGS =over 4 =item * The only pragmas to be completely supported are: C<use warnings>, C<use strict>, C<use bytes>, C<use integer> 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. (Specifically, pragmas at the beginning of a block often appear right before the start of the block instead.) Since the effects of pragmas are often lexically scoped, this can mean that the pragma holds sway over a different portion of the program than in the input file. =item * In fact, the above is a specific instance of a more general problem: we can't guarantee to produce BEGIN blocks or C<use> declarations in 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. =item * Some constants don't print correctly either with or without B<-d>. For instance, neither B::Deparse nor Data::Dumper know how to print dual-valued scalars correctly, as in: use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y; use constant H => { "#" => 1 }; H->{"#"}; =item * An input file that uses source filtering probably won't be deparsed into runnable code, because it will still include the B<use> declaration for the source filtering module, even though the code that is produced is already ordinary Perl which shouldn't be filtered again. =item * Optimized-away statements are rendered as '???'. This includes statements that have a compile-time side-effect, such as the obscure my $x if 0; which is not, consequently, deparsed correctly. foreach my $i (@_) { 0 } => foreach my $i (@_) { '???' } =item * Lexical (my) variables declared in scopes external to a subroutine 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. See also L<Data::Dump::Streamer>, which combines B::Deparse and L<PadWalker> to serialize closures properly. =item * There are probably many more bugs on non-ASCII platforms (EBCDIC). =back =head1 AUTHOR Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell, Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael Garcia-Suarez. =cut Op_private.pm 0000644 00000113464 15125173167 0007233 0 ustar 00 # -*- buffer-read-only: t -*- # # lib/B/Op_private.pm # # Copyright (C) 2014 by Larry Wall and others # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the README file. # # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! # This file is built by regen/opcode.pl from data in # regen/op_private and pod embedded in regen/opcode.pl. # Any changes made here will be lost! =head1 NAME B::Op_private - OP op_private flag definitions =head1 SYNOPSIS use B::Op_private; # flag details for bit 7 of OP_AELEM's op_private: my $name = $B::Op_private::bits{aelem}{7}; # OPpLVAL_INTRO my $value = $B::Op_private::defines{$name}; # 128 my $label = $B::Op_private::labels{$name}; # LVINTRO # the bit field at bits 5..6 of OP_AELEM's op_private: my $bf = $B::Op_private::bits{aelem}{6}; my $mask = $bf->{bitmask}; # etc =head1 DESCRIPTION This module provides four global hashes: %B::Op_private::bits %B::Op_private::defines %B::Op_private::labels %B::Op_private::ops_using which contain information about the per-op meanings of the bits in the op_private field. =head2 C<%bits> This is indexed by op name and then bit number (0..7). For single bit flags, it returns the name of the define (if any) for that bit: $B::Op_private::bits{aelem}{7} eq 'OPpLVAL_INTRO'; For bit fields, it returns a hash ref containing details about the field. The same reference will be returned for all bit positions that make up the bit field; so for example these both return the same hash ref: $bitfield = $B::Op_private::bits{aelem}{5}; $bitfield = $B::Op_private::bits{aelem}{6}; The general format of this hash ref is { # The bit range and mask; these are always present. bitmin => 5, bitmax => 6, bitmask => 0x60, # (The remaining keys are optional) # The names of any defines that were requested: mask_def => 'OPpFOO_MASK', baseshift_def => 'OPpFOO_SHIFT', bitcount_def => 'OPpFOO_BITS', # If present, Concise etc will display the value with a 'FOO=' # prefix. If it equals '-', then Concise will treat the bit # field as raw bits and not try to interpret it. label => 'FOO', # If present, specifies the names of some defines and the # display labels that are used to assign meaning to particu- # lar integer values within the bit field; e.g. 3 is dis- # played as 'C'. enum => [ qw( 1 OPpFOO_A A 2 OPpFOO_B B 3 OPpFOO_C C )], }; =head2 C<%defines> This gives the value of every C<OPp> define, e.g. $B::Op_private::defines{OPpLVAL_INTRO} == 128; =head2 C<%labels> This gives the short display label for each define, as used by C<B::Concise> and C<perl -Dx>, e.g. $B::Op_private::labels{OPpLVAL_INTRO} eq 'LVINTRO'; If the label equals '-', then Concise will treat the bit as a raw bit and not try to display it symbolically. =head2 C<%ops_using> For each define, this gives a reference to an array of op names that use the flag. @ops_using_lvintro = @{ $B::Op_private::ops_using{OPp_LVAL_INTRO} }; =cut package B::Op_private; our %bits; our $VERSION = "5.032001"; $bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv); $bits{$_}{6} = 'OPpENTERSUB_DB' for qw(entersub rv2cv); $bits{$_}{2} = 'OPpENTERSUB_HASTARG' for qw(entersub rv2cv); $bits{$_}{6} = 'OPpFLIP_LINENUM' for qw(flip flop); $bits{$_}{1} = 'OPpFT_ACCESS' for qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite); $bits{$_}{4} = 'OPpFT_AFTER_t' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero); $bits{$_}{2} = 'OPpFT_STACKED' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero); $bits{$_}{3} = 'OPpFT_STACKING' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero); $bits{$_}{1} = '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 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 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); $bits{$_}{7} = 'OPpOPEN_OUT_CRLF' for qw(backtick open); $bits{$_}{6} = 'OPpOPEN_OUT_RAW' for qw(backtick open); $bits{$_}{6} = 'OPpOUR_INTRO' for qw(enteriter gvsv rv2av rv2hv rv2sv split); $bits{$_}{6} = 'OPpPAD_STATE' for qw(lvavref lvref padav padhv padsv pushmark refassign); $bits{$_}{7} = 'OPpPV_IS_UTF8' for qw(dump goto last next redo); $bits{$_}{6} = 'OPpREFCOUNTED' for qw(leave leaveeval leavesub leavesublv leavewrite); $bits{$_}{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 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{$_}{0} = 'OPpTRANS_CAN_FORCE_UTF8' for qw(trans transr); $bits{$_}{5} = 'OPpTRANS_COMPLEMENT' for qw(trans transr); $bits{$_}{7} = 'OPpTRANS_DELETE' for qw(trans transr); $bits{$_}{6} = 'OPpTRANS_GROWS' for qw(trans transr); $bits{$_}{2} = 'OPpTRANS_IDENTICAL' for qw(trans transr); $bits{$_}{3} = 'OPpTRANS_SQUASH' for qw(trans transr); $bits{$_}{1} = 'OPpTRANS_USE_SVOP' for qw(trans transr); $bits{$_}{5} = 'OPpTRUEBOOL' for qw(grepwhile index length padav padhv pos ref rindex rv2av rv2hv subst); my @bf = ( { label => '-', mask_def => 'OPpARG1_MASK', bitmin => 0, bitmax => 0, bitmask => 1, }, { label => '-', mask_def => 'OPpARG2_MASK', bitmin => 0, bitmax => 1, bitmask => 3, }, { label => 'offset', mask_def => 'OPpAVHVSWITCH_MASK', bitmin => 0, bitmax => 1, bitmask => 3, }, { label => '-', mask_def => 'OPpARG3_MASK', bitmin => 0, bitmax => 2, bitmask => 7, }, { label => '-', mask_def => 'OPpARG4_MASK', bitmin => 0, bitmax => 3, bitmask => 15, }, { label => 'range', mask_def => 'OPpPADRANGE_COUNTMASK', bitcount_def => 'OPpPADRANGE_COUNTSHIFT', bitmin => 0, bitmax => 6, bitmask => 127, }, { 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, bitmask => 48, enum => [ 1, 'OPpDEREF_AV', 'DREFAV', 2, 'OPpDEREF_HV', 'DREFHV', 3, 'OPpDEREF_SV', 'DREFSV', ], }, { mask_def => 'OPpLVREF_TYPE', bitmin => 4, bitmax => 5, bitmask => 48, enum => [ 0, 'OPpLVREF_SV', 'SV', 1, 'OPpLVREF_AV', 'AV', 2, 'OPpLVREF_HV', 'HV', 3, 'OPpLVREF_CV', 'CV', ], }, ); @{$bits{aassign}}{6,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[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[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[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[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[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[4], $bf[4], $bf[4], $bf[4]); $bits{chr}{0} = $bf[0]; $bits{chroot}{0} = $bf[0]; @{$bits{close}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{closedir}{0} = $bf[0]; $bits{cmpchain_and}{0} = $bf[0]; $bits{cmpchain_dup}{0} = $bf[0]; $bits{complement}{0} = $bf[0]; @{$bits{concat}}{6,1,0} = ('OPpCONCAT_NESTED', $bf[1], $bf[1]); $bits{cond_expr}{0} = $bf[0]; @{$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[4], $bf[4], $bf[4], $bf[4]); $bits{dbmclose}{0} = $bf[0]; @{$bits{dbmopen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{defined}{0} = $bf[0]; @{$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]; $bits{dorassign}{0} = $bf[0]; $bits{dump}{0} = $bf[0]; $bits{each}{0} = $bf[0]; @{$bits{entereval}}{5,4,3,2,1,0} = ('OPpEVAL_RE_REPARSING', 'OPpEVAL_COPHH', 'OPpEVAL_BYTES', 'OPpEVAL_UNICODE', 'OPpEVAL_HAS_HH', $bf[0]); $bits{entergiven}{0} = $bf[0]; $bits{enteriter}{3} = 'OPpITER_DEF'; @{$bits{entersub}}{5,4,0} = ($bf[8], $bf[8], 'OPpENTERSUB_INARGS'); $bits{entertry}{0} = $bf[0]; $bits{enterwhen}{0} = $bf[0]; @{$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[4], $bf[4], $bf[4], $bf[4]); @{$bits{exists}}{6,0} = ('OPpEXISTS_SUB', $bf[0]); @{$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[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[4], $bf[4], $bf[4], $bf[4]); $bits{flop}{0} = $bf[0]; @{$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]; $bits{ftchr}{0} = $bf[0]; $bits{ftctime}{0} = $bf[0]; $bits{ftdir}{0} = $bf[0]; $bits{fteexec}{0} = $bf[0]; $bits{fteowned}{0} = $bf[0]; $bits{fteread}{0} = $bf[0]; $bits{ftewrite}{0} = $bf[0]; $bits{ftfile}{0} = $bf[0]; $bits{ftis}{0} = $bf[0]; $bits{ftlink}{0} = $bf[0]; $bits{ftmtime}{0} = $bf[0]; $bits{ftpipe}{0} = $bf[0]; $bits{ftrexec}{0} = $bf[0]; $bits{ftrowned}{0} = $bf[0]; $bits{ftrread}{0} = $bf[0]; $bits{ftrwrite}{0} = $bf[0]; $bits{ftsgid}{0} = $bf[0]; $bits{ftsize}{0} = $bf[0]; $bits{ftsock}{0} = $bf[0]; $bits{ftsuid}{0} = $bf[0]; $bits{ftsvtx}{0} = $bf[0]; $bits{fttext}{0} = $bf[0]; $bits{fttty}{0} = $bf[0]; $bits{ftzero}{0} = $bf[0]; @{$bits{ge}}{1,0} = ($bf[1], $bf[1]); @{$bits{gelem}}{1,0} = ($bf[1], $bf[1]); @{$bits{getc}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{getpeername}{0} = $bf[0]; @{$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[4], $bf[4], $bf[4], $bf[4]); $bits{ghbyname}{0} = $bf[0]; @{$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[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[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[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]); @{$bits{i_eq}}{1,0} = ($bf[1], $bf[1]); @{$bits{i_ge}}{1,0} = ($bf[1], $bf[1]); @{$bits{i_gt}}{1,0} = ($bf[1], $bf[1]); @{$bits{i_le}}{1,0} = ($bf[1], $bf[1]); @{$bits{i_lt}}{1,0} = ($bf[1], $bf[1]); @{$bits{i_modulo}}{1,0} = ($bf[1], $bf[1]); @{$bits{i_multiply}}{1,0} = ($bf[1], $bf[1]); @{$bits{i_ncmp}}{1,0} = ($bf[1], $bf[1]); @{$bits{i_ne}}{1,0} = ($bf[1], $bf[1]); $bits{i_negate}{0} = $bf[0]; $bits{i_postdec}{0} = $bf[0]; $bits{i_postinc}{0} = $bf[0]; $bits{i_predec}{0} = $bf[0]; $bits{i_preinc}{0} = $bf[0]; @{$bits{i_subtract}}{1,0} = ($bf[1], $bf[1]); @{$bits{index}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{int}{0} = $bf[0]; @{$bits{ioctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$bits{isa}}{1,0} = ($bf[1], $bf[1]); @{$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[4], $bf[4], $bf[4], $bf[4]); $bits{last}{0} = $bf[0]; $bits{lc}{0} = $bf[0]; $bits{lcfirst}{0} = $bf[0]; @{$bits{le}}{1,0} = ($bf[1], $bf[1]); $bits{leaveeval}{0} = $bf[0]; $bits{leavegiven}{0} = $bf[0]; @{$bits{leaveloop}}{1,0} = ($bf[1], $bf[1]); $bits{leavesub}{0} = $bf[0]; $bits{leavesublv}{0} = $bf[0]; $bits{leavewhen}{0} = $bf[0]; $bits{leavewrite}{0} = $bf[0]; @{$bits{left_shift}}{1,0} = ($bf[1], $bf[1]); $bits{length}{0} = $bf[0]; @{$bits{link}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{list}{6} = 'OPpLIST_GUESSED'; @{$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]; @{$bits{lslice}}{1,0} = ($bf[1], $bf[1]); $bits{lstat}{0} = $bf[0]; @{$bits{lt}}{1,0} = ($bf[1], $bf[1]); $bits{lvavref}{0} = $bf[0]; @{$bits{lvref}}{5,4,0} = ($bf[9], $bf[9], $bf[0]); $bits{mapstart}{0} = $bf[0]; $bits{mapwhile}{0} = $bf[0]; $bits{method}{0} = $bf[0]; $bits{method_named}{0} = $bf[0]; $bits{method_redir}{0} = $bf[0]; $bits{method_redir_super}{0} = $bf[0]; $bits{method_super}{0} = $bf[0]; @{$bits{mkdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$bits{modulo}}{1,0} = ($bf[1], $bf[1]); @{$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]); @{$bits{nbit_or}}{1,0} = ($bf[1], $bf[1]); @{$bits{nbit_xor}}{1,0} = ($bf[1], $bf[1]); @{$bits{ncmp}}{1,0} = ($bf[1], $bf[1]); $bits{ncomplement}{0} = $bf[0]; @{$bits{ne}}{1,0} = ($bf[1], $bf[1]); $bits{negate}{0} = $bf[0]; $bits{next}{0} = $bf[0]; $bits{not}{0} = $bf[0]; $bits{oct}{0} = $bf[0]; $bits{once}{0} = $bf[0]; @{$bits{open}}{3,2,1,0} = ($bf[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[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]; $bits{postinc}{0} = $bf[0]; @{$bits{pow}}{1,0} = ($bf[1], $bf[1]); $bits{predec}{0} = $bf[0]; $bits{preinc}{0} = $bf[0]; $bits{prototype}{0} = $bf[0]; @{$bits{push}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{quotemeta}{0} = $bf[0]; @{$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[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[4], $bf[4], $bf[4], $bf[4]); $bits{redo}{0} = $bf[0]; $bits{ref}{0} = $bf[0]; @{$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[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[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[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[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]); @{$bits{sbit_xor}}{1,0} = ($bf[1], $bf[1]); $bits{scalar}{0} = $bf[0]; $bits{schomp}{0} = $bf[0]; $bits{schop}{0} = $bf[0]; @{$bits{scmp}}{1,0} = ($bf[1], $bf[1]); $bits{scomplement}{0} = $bf[0]; @{$bits{seek}}{3,2,1,0} = ($bf[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[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[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[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[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[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[4], $bf[4], $bf[4], $bf[4]); $bits{srefgen}{0} = $bf[0]; @{$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[4], $bf[4], $bf[4], $bf[4]); $bits{stat}{0} = $bf[0]; @{$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[3], $bf[3], $bf[3]); @{$bits{subtract}}{1,0} = ($bf[1], $bf[1]); @{$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[4], $bf[4], $bf[4], $bf[4]); $bits{tied}{0} = $bf[0]; @{$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[4], $bf[4], $bf[4], $bf[4]); $bits{undef}{0} = $bf[0]; @{$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[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[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]); our %defines = ( OPpALLOW_FAKE => 64, OPpARG1_MASK => 1, 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, OPpCONST_SHORTCIRCUIT => 4, OPpCONST_STRICT => 8, OPpCOREARGS_DEREF1 => 1, OPpCOREARGS_DEREF2 => 2, OPpCOREARGS_PUSHMARK => 128, OPpCOREARGS_SCALARMOD => 64, OPpDEREF => 48, OPpDEREF_AV => 16, OPpDEREF_HV => 32, OPpDEREF_SV => 48, OPpDONT_INIT_GV => 4, OPpEARLY_CV => 32, OPpENTERSUB_AMPER => 8, OPpENTERSUB_DB => 64, OPpENTERSUB_HASTARG => 4, OPpENTERSUB_INARGS => 1, OPpENTERSUB_NOPAREN => 128, OPpEVAL_BYTES => 8, OPpEVAL_COPHH => 16, OPpEVAL_HAS_HH => 2, OPpEVAL_RE_REPARSING => 32, OPpEVAL_UNICODE => 4, OPpEXISTS_SUB => 64, OPpFLIP_LINENUM => 64, OPpFT_ACCESS => 2, OPpFT_AFTER_t => 16, OPpFT_STACKED => 4, OPpFT_STACKING => 8, 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, OPpLVAL_INTRO => 128, OPpLVREF_AV => 16, OPpLVREF_CV => 48, OPpLVREF_ELEM => 4, OPpLVREF_HV => 32, OPpLVREF_ITER => 8, OPpLVREF_SV => 0, OPpLVREF_TYPE => 48, OPpMAYBE_LVSUB => 8, OPpMAYBE_TRUEBOOL => 16, OPpMAY_RETURN_CONSTANT => 32, OPpMULTICONCAT_APPEND => 64, OPpMULTICONCAT_FAKE => 32, OPpMULTICONCAT_STRINGIFY => 8, OPpMULTIDEREF_DELETE => 32, OPpMULTIDEREF_EXISTS => 16, OPpOFFBYONE => 128, OPpOPEN_IN_CRLF => 32, OPpOPEN_IN_RAW => 16, OPpOPEN_OUT_CRLF => 128, OPpOPEN_OUT_RAW => 64, OPpOUR_INTRO => 64, OPpPADHV_ISKEYS => 1, OPpPADRANGE_COUNTMASK => 127, OPpPADRANGE_COUNTSHIFT => 7, OPpPAD_STATE => 64, OPpPV_IS_UTF8 => 128, OPpREFCOUNTED => 64, OPpREPEAT_DOLIST => 64, OPpREVERSE_INPLACE => 8, OPpRV2HV_ISKEYS => 1, OPpSLICE => 64, OPpSLICEWARNING => 4, OPpSORT_DESCEND => 16, OPpSORT_INPLACE => 8, OPpSORT_INTEGER => 2, OPpSORT_NUMERIC => 1, OPpSORT_REVERSE => 4, OPpSORT_STABLE => 64, OPpSORT_UNSTABLE => 128, OPpSPLIT_ASSIGN => 16, OPpSPLIT_IMPLIM => 4, OPpSPLIT_LEX => 8, OPpSUBSTR_REPL_FIRST => 16, OPpTARGET_MY => 16, OPpTRANS_CAN_FORCE_UTF8 => 1, OPpTRANS_COMPLEMENT => 32, OPpTRANS_DELETE => 128, OPpTRANS_GROWS => 64, OPpTRANS_IDENTICAL => 4, OPpTRANS_SQUASH => 8, OPpTRANS_USE_SVOP => 2, OPpTRUEBOOL => 32, ); 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', OPpCONST_SHORTCIRCUIT => 'SHORT', OPpCONST_STRICT => 'STRICT', OPpCOREARGS_DEREF1 => 'DEREF1', OPpCOREARGS_DEREF2 => 'DEREF2', OPpCOREARGS_PUSHMARK => 'MARK', OPpCOREARGS_SCALARMOD => '$MOD', OPpDEREF_AV => 'DREFAV', OPpDEREF_HV => 'DREFHV', OPpDEREF_SV => 'DREFSV', OPpDONT_INIT_GV => 'NOINIT', OPpEARLY_CV => 'EARLYCV', OPpENTERSUB_AMPER => 'AMPER', OPpENTERSUB_DB => 'DBG', OPpENTERSUB_HASTARG => 'TARG', OPpENTERSUB_INARGS => 'INARGS', OPpENTERSUB_NOPAREN => 'NO()', OPpEVAL_BYTES => 'BYTES', OPpEVAL_COPHH => 'COPHH', OPpEVAL_HAS_HH => 'HAS_HH', OPpEVAL_RE_REPARSING => 'REPARSE', OPpEVAL_UNICODE => 'UNI', OPpEXISTS_SUB => 'SUB', OPpFLIP_LINENUM => 'LINENUM', OPpFT_ACCESS => 'FTACCESS', OPpFT_AFTER_t => 'FTAFTERt', OPpFT_STACKED => 'FTSTACKED', OPpFT_STACKING => 'FTSTACKING', 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', OPpLVAL_INTRO => 'LVINTRO', OPpLVREF_AV => 'AV', OPpLVREF_CV => 'CV', OPpLVREF_ELEM => 'ELEM', OPpLVREF_HV => 'HV', OPpLVREF_ITER => 'ITER', OPpLVREF_SV => 'SV', OPpMAYBE_LVSUB => 'LVSUB', OPpMAYBE_TRUEBOOL => 'BOOL?', OPpMAY_RETURN_CONSTANT => 'CONST', OPpMULTICONCAT_APPEND => 'APPEND', OPpMULTICONCAT_FAKE => 'FAKE', OPpMULTICONCAT_STRINGIFY => 'STRINGIFY', OPpMULTIDEREF_DELETE => 'DELETE', OPpMULTIDEREF_EXISTS => 'EXISTS', OPpOFFBYONE => '+1', OPpOPEN_IN_CRLF => 'INCR', OPpOPEN_IN_RAW => 'INBIN', OPpOPEN_OUT_CRLF => 'OUTCR', OPpOPEN_OUT_RAW => 'OUTBIN', OPpOUR_INTRO => 'OURINTR', OPpPADHV_ISKEYS => 'KEYS', OPpPAD_STATE => 'STATE', OPpPV_IS_UTF8 => 'UTF', OPpREFCOUNTED => 'REFC', OPpREPEAT_DOLIST => 'DOLIST', OPpREVERSE_INPLACE => 'INPLACE', OPpRV2HV_ISKEYS => 'KEYS', OPpSLICE => 'SLICE', OPpSLICEWARNING => 'SLICEWARN', OPpSORT_DESCEND => 'DESC', OPpSORT_INPLACE => 'INPLACE', OPpSORT_INTEGER => 'INT', OPpSORT_NUMERIC => 'NUM', 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_CAN_FORCE_UTF8 => 'CAN_FORCE_UTF8', OPpTRANS_COMPLEMENT => 'COMPL', OPpTRANS_DELETE => 'DEL', OPpTRANS_GROWS => 'GROWS', OPpTRANS_IDENTICAL => 'IDENT', OPpTRANS_SQUASH => 'SQUASH', OPpTRANS_USE_SVOP => 'USE_SVOP', OPpTRUEBOOL => 'BOOL', ); 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)], OPpENTERSUB_AMPER => [qw(entersub rv2cv)], OPpENTERSUB_INARGS => [qw(entersub)], OPpENTERSUB_NOPAREN => [qw(rv2cv)], OPpEVAL_BYTES => [qw(entereval)], OPpEXISTS_SUB => [qw(exists)], OPpFLIP_LINENUM => [qw(flip flop)], OPpFT_ACCESS => [qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite)], OPpFT_AFTER_t => [qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero)], 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 multiconcat multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv split)], OPpLVREF_ELEM => [qw(lvref refassign)], 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)], OPpRV2HV_ISKEYS => [qw(rv2hv)], OPpSLICEWARNING => [qw(aslice hslice padav padhv rv2av rv2hv)], OPpSORT_DESCEND => [qw(sort)], 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 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_CAN_FORCE_UTF8 => [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}; $ops_using{OPpCONST_STRICT} = $ops_using{OPpCONST_BARE}; $ops_using{OPpCOREARGS_DEREF2} = $ops_using{OPpCOREARGS_DEREF1}; $ops_using{OPpCOREARGS_PUSHMARK} = $ops_using{OPpCOREARGS_DEREF1}; $ops_using{OPpCOREARGS_SCALARMOD} = $ops_using{OPpCOREARGS_DEREF1}; $ops_using{OPpDONT_INIT_GV} = $ops_using{OPpALLOW_FAKE}; $ops_using{OPpENTERSUB_DB} = $ops_using{OPpENTERSUB_AMPER}; $ops_using{OPpENTERSUB_HASTARG} = $ops_using{OPpENTERSUB_AMPER}; $ops_using{OPpEVAL_COPHH} = $ops_using{OPpEVAL_BYTES}; $ops_using{OPpEVAL_HAS_HH} = $ops_using{OPpEVAL_BYTES}; $ops_using{OPpEVAL_RE_REPARSING} = $ops_using{OPpEVAL_BYTES}; $ops_using{OPpEVAL_UNICODE} = $ops_using{OPpEVAL_BYTES}; $ops_using{OPpFT_STACKED} = $ops_using{OPpFT_AFTER_t}; $ops_using{OPpFT_STACKING} = $ops_using{OPpFT_AFTER_t}; $ops_using{OPpLVREF_ITER} = $ops_using{OPpLVREF_ELEM}; $ops_using{OPpMAY_RETURN_CONSTANT} = $ops_using{OPpENTERSUB_NOPAREN}; $ops_using{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_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_COMPLEMENT} = $ops_using{OPpTRANS_CAN_FORCE_UTF8}; $ops_using{OPpTRANS_DELETE} = $ops_using{OPpTRANS_CAN_FORCE_UTF8}; $ops_using{OPpTRANS_GROWS} = $ops_using{OPpTRANS_CAN_FORCE_UTF8}; $ops_using{OPpTRANS_IDENTICAL} = $ops_using{OPpTRANS_CAN_FORCE_UTF8}; $ops_using{OPpTRANS_SQUASH} = $ops_using{OPpTRANS_CAN_FORCE_UTF8}; $ops_using{OPpTRANS_USE_SVOP} = $ops_using{OPpTRANS_CAN_FORCE_UTF8}; # ex: set ro: Terse.pm 0000644 00000005531 15125210275 0006170 0 ustar 00 package B::Terse; our $VERSION = '1.09'; use strict; use B qw(class @specialsv_name); use B::Concise qw(concise_subref set_style_standard); use Carp; sub terse { my ($order, $subref) = @_; set_style_standard("terse"); if ($order eq "exec") { concise_subref('exec', $subref); } else { concise_subref('basic', $subref); } } sub compile { my @args = @_; my $order = @args ? shift(@args) : ""; $order = "-exec" if $order eq "exec"; unshift @args, $order if $order ne ""; B::Concise::compile("-terse", @args); } sub indent { my ($level) = @_ ? shift : 0; return " " x $level; } sub B::SV::terse { my($sv, $level) = (@_, 0); my %info; B::Concise::concise_sv($sv, \%info); my $s = indent($level) . B::Concise::fmt_line(\%info, $sv, "#svclass~(?((#svaddr))?)~#svval", 0); chomp $s; print "$s\n" unless defined wantarray; $s; } sub B::NULL::terse { my ($sv, $level) = (@_, 0); my $s = indent($level) . sprintf "%s (0x%lx)", class($sv), $$sv; print "$s\n" unless defined wantarray; $s; } sub B::SPECIAL::terse { my ($sv, $level) = (@_, 0); my $s = indent($level) . sprintf( "%s #%d %s", class($sv), $$sv, $specialsv_name[$$sv]); print "$s\n" unless defined wantarray; $s; } 1; __END__ =head1 NAME B::Terse - Walk Perl syntax tree, printing terse info about ops =head1 SYNOPSIS perl -MO=Terse[,OPTIONS] foo.pl =head1 DESCRIPTION This module prints the contents of the parse tree, but without as much information as CPAN module B::Debug. For comparison, C<print "Hello, world."> produced 96 lines of output from B::Debug, but only 6 from B::Terse. This module is useful for people who are writing their own back end, or who are learning about the Perl internals. It's not useful to the average programmer. This version of B::Terse is really just a wrapper that calls L<B::Concise> with the B<-terse> option. It is provided for compatibility with old scripts (and habits) but using B::Concise directly is now recommended instead. For compatibility with the old B::Terse, this module also adds a method named C<terse> to B::OP and B::SV objects. The B::SV method is largely compatible with the old one, though authors of new software might be advised to choose a more user-friendly output format. The B::OP C<terse> method, however, doesn't work well. Since B::Terse was first written, much more information in OPs has migrated to the scratchpad datastructure, but the C<terse> interface doesn't have any way of getting to the correct pad. As a kludge, the new version will always use the pad for the main program, but for OPs in subroutines this will give the wrong answer or crash. =head1 AUTHOR The original version of B::Terse was written by Malcolm Beattie, E<lt>mbeattie@sable.ox.ac.ukE<gt>. This wrapper was written by Stephen McCamant, E<lt>smcc@MIT.EDUE<gt>. =cut Showlex.pm 0000644 00000013030 15125210275 0006530 0 ustar 00 package B::Showlex; our $VERSION = '1.05'; use strict; use B qw(svref_2object comppadlist class); use B::Terse (); use B::Concise (); # # Invoke as # perl -MO=Showlex,foo bar.pl # to see the names of lexical variables used by &foo # or as # perl -MO=Showlex bar.pl # to see the names of file scope lexicals used by bar.pl # # borrowed from B::Concise our $walkHandle = \*STDOUT; sub walk_output { # updates $walkHandle $walkHandle = B::Concise::walk_output(@_); #print "got $walkHandle"; #print $walkHandle "using it"; $walkHandle; } sub shownamearray { my ($name, $av) = @_; my @els = $av->ARRAY; my $count = @els; my $i; print $walkHandle "$name has $count entries\n"; for ($i = 0; $i < $count; $i++) { my $sv = $els[$i]; if (class($sv) ne "SPECIAL") { printf $walkHandle "$i: (0x%lx) %s\n", $$sv, $sv->PVX // "undef" || "const"; } else { printf $walkHandle "$i: %s\n", $sv->terse; #printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv); } } } sub showvaluearray { my ($name, $av) = @_; my @els = $av->ARRAY; my $count = @els; my $i; print $walkHandle "$name has $count entries\n"; for ($i = 0; $i < $count; $i++) { printf $walkHandle "$i: %s\n", $els[$i]->terse; #print $walkHandle "$i: %s\n", B::Concise::concise_sv($els[$i]); } } sub showlex { my ($objname, $namesav, $valsav) = @_; shownamearray("Pad of lexical names for $objname", $namesav); showvaluearray("Pad of lexical values for $objname", $valsav); } my ($newlex, $nosp1); # rendering state vars sub padname_terse { my $name = shift; return $name->terse if class($name) eq 'SPECIAL'; my $str = $name->PVX; return sprintf "(0x%lx) %s", $$name, length $str ? qq'"$str"' : defined $str ? "const" : 'undef'; } sub newlex { # drop-in for showlex my ($objname, $names, $vals) = @_; my @names = $names->ARRAY; my @vals = $vals->ARRAY; my $count = @names; print $walkHandle "$objname Pad has $count entries\n"; printf $walkHandle "0: %s\n", padname_terse($names[0]) unless $nosp1; for (my $i = 1; $i < $count; $i++) { printf $walkHandle "$i: %s = %s\n", padname_terse($names[$i]), $vals[$i]->terse, unless $nosp1 and class($names[$i]) eq 'SPECIAL' || !$names[$i]->LEN; } } sub showlex_obj { my ($objname, $obj) = @_; $objname =~ s/^&main::/&/; showlex($objname, svref_2object($obj)->PADLIST->ARRAY) if !$newlex; newlex ($objname, svref_2object($obj)->PADLIST->ARRAY) if $newlex; } sub showlex_main { showlex("comppadlist", comppadlist->ARRAY) if !$newlex; newlex ("main", comppadlist->ARRAY) if $newlex; } sub compile { my @options = grep(/^-/, @_); my @args = grep(!/^-/, @_); for my $o (@options) { $newlex = 1 if $o eq "-newlex"; $nosp1 = 1 if $o eq "-nosp"; } return \&showlex_main unless @args; return sub { my $objref; foreach my $objname (@args) { next unless $objname; # skip nulls w/o carping if (ref $objname) { print $walkHandle "B::Showlex::compile($objname)\n"; $objref = $objname; } else { $objname = "main::$objname" unless $objname =~ /::/; print $walkHandle "$objname:\n"; no strict 'refs'; die "err: unknown function ($objname)\n" unless *{$objname}{CODE}; $objref = \&$objname; } showlex_obj($objname, $objref); } } } 1; __END__ =head1 NAME B::Showlex - Show lexical variables used in functions or files =head1 SYNOPSIS perl -MO=Showlex[,-OPTIONS][,SUBROUTINE] foo.pl =head1 DESCRIPTION When a comma-separated list of subroutine names is given as options, Showlex prints the lexical variables used in those subroutines. Otherwise, it prints the file-scope lexicals in the file. =head1 EXAMPLES Traditional form: $ perl -MO=Showlex -e 'my ($i,$j,$k)=(1,"foo")' Pad of lexical names for comppadlist has 4 entries 0: (0x8caea4) undef 1: (0x9db0fb0) $i 2: (0x9db0f38) $j 3: (0x9db0f50) $k Pad of lexical values for comppadlist has 5 entries 0: SPECIAL #1 &PL_sv_undef 1: NULL (0x9da4234) 2: NULL (0x9db0f2c) 3: NULL (0x9db0f44) 4: NULL (0x9da4264) -e syntax OK New-style form: $ perl -MO=Showlex,-newlex -e 'my ($i,$j,$k)=(1,"foo")' main Pad has 4 entries 0: (0x8caea4) undef 1: (0xa0c4fb8) "$i" = NULL (0xa0b8234) 2: (0xa0c4f40) "$j" = NULL (0xa0c4f34) 3: (0xa0c4f58) "$k" = NULL (0xa0c4f4c) -e syntax OK New form, no specials, outside O framework: $ perl -MB::Showlex -e \ 'my ($i,$j,$k)=(1,"foo"); B::Showlex::compile(-newlex,-nosp)->()' main Pad has 4 entries 1: (0x998ffb0) "$i" = IV (0x9983234) 1 2: (0x998ff68) "$j" = PV (0x998ff5c) "foo" 3: (0x998ff80) "$k" = NULL (0x998ff74) Note that this example shows the values of the lexicals, whereas the other examples did not (as they're compile-time only). =head2 OPTIONS The C<-newlex> option produces a more readable C<< name => value >> format, and is shown in the second example above. The C<-nosp> option eliminates reporting of SPECIALs, such as C<0: SPECIAL #1 &PL_sv_undef> above. Reporting of SPECIALs can sometimes overwhelm your declared lexicals. =head1 SEE ALSO L<B::Showlex> can also be used outside of the O framework, as in the third example. See L<B::Concise> for a fuller explanation of reasons. =head1 TODO Some of the reported info, such as hex addresses, is not particularly valuable. Other information would be more useful for the typical programmer, such as line-numbers, pad-slot reuses, etc.. Given this, -newlex is not a particularly good flag-name. =head1 AUTHOR Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> =cut Xref.pm 0000644 00000030316 15125210275 0006011 0 ustar 00 package B::Xref; our $VERSION = '1.07'; =head1 NAME B::Xref - Generates cross reference reports for Perl programs =head1 SYNOPSIS perl -MO=Xref[,OPTIONS] foo.pl =head1 DESCRIPTION The B::Xref module is used to generate a cross reference listing of all definitions and uses of variables, subroutines and formats in a Perl program. It is implemented as a backend for the Perl compiler. The report generated is in the following format: File filename1 Subroutine subname1 Package package1 object1 line numbers object2 line numbers ... Package package2 ... Each B<File> section reports on a single file. Each B<Subroutine> section reports on a single subroutine apart from the special cases "(definitions)" and "(main)". These report, respectively, on subroutine definitions found by the initial symbol table walk and on the main part of the program or module external to all subroutines. The report is then grouped by the B<Package> of each variable, subroutine or format with the special case "(lexicals)" meaning lexical variables. Each B<object> name (implicitly qualified by its containing B<Package>) includes its type character(s) at the beginning where possible. Lexical variables are easier to track and even included dereferencing information where possible. The C<line numbers> are a comma separated list of line numbers (some preceded by code letters) where that object is used in some way. Simple uses aren't preceded by a code letter. Introductions (such as where a lexical is first defined with C<my>) are indicated with the letter "i". Subroutine and method calls are indicated by the character "&". Subroutine definitions are indicated by "s" and format definitions by "f". For instance, here's part of the report from the I<pod2man> program that comes with Perl: Subroutine clear_noremap Package (lexical) $ready_to_print i1069, 1079 Package main $& 1086 $. 1086 $0 1086 $1 1087 $2 1085, 1085 $3 1085, 1085 $ARGV 1086 %HTML_Escapes 1085, 1085 This shows the variables used in the subroutine C<clear_noremap>. The variable C<$ready_to_print> is a my() (lexical) variable, B<i>ntroduced (first declared with my()) on line 1069, and used on line 1079. The variable C<$&> from the main package is used on 1086, and so on. A line number may be prefixed by a single letter: =over 4 =item i Lexical variable introduced (declared with my()) for the first time. =item & Subroutine or method call. =item s Subroutine defined. =item r Format defined. =back The most useful option the cross referencer has is to save the report to a separate file. For instance, to save the report on I<myperlprogram> to the file I<report>: $ perl -MO=Xref,-oreport myperlprogram =head1 OPTIONS Option words are separated by commas (not whitespace) and follow the usual conventions of compiler backend options. =over 8 =item C<-oFILENAME> Directs output to C<FILENAME> instead of standard output. =item C<-r> Raw output. Instead of producing a human-readable report, outputs a line in machine-readable form for each definition/use of a variable/sub/format. =item C<-d> Don't output the "(definitions)" sections. =item C<-D[tO]> (Internal) debug options, probably only useful if C<-r> included. The C<t> option prints the object on the top of the stack as it's being tracked. The C<O> option prints each operator as it's being processed in the execution order of the program. =back =head1 BUGS Non-lexical variables are quite difficult to track through a program. Sometimes the type of a non-lexical variable's use is impossible to determine. Introductions of non-lexical non-scalars don't seem to be reported properly. =head1 AUTHOR Malcolm Beattie, mbeattie@sable.ox.ac.uk. =cut use strict; use Config; use B qw(peekop class comppadlist main_start svref_2object walksymtable OPpLVAL_INTRO SVf_POK SVf_ROK OPpOUR_INTRO cstring ); sub UNKNOWN { ["?", "?", "?"] } my @pad; # lexicals in current pad # as ["(lexical)", type, name] my %done; # keyed by $$op: set when each $op is done my $top = UNKNOWN; # shadows top element of stack as # [pack, type, name] (pack can be "(lexical)") my $file; # shadows current filename my $line; # shadows current line number my $subname; # shadows current sub name my %table; # Multi-level hash to record all uses etc. my @todo = (); # List of CVs that need processing my %code = (intro => "i", used => "", subdef => "s", subused => "&", formdef => "f", meth => "->"); # Options my ($debug_op, $debug_top, $nodefs, $raw); sub process { my ($var, $event) = @_; my ($pack, $type, $name) = @$var; if ($type eq "*") { if ($event eq "used") { return; } elsif ($event eq "subused") { $type = "&"; } } $type =~ s/(.)\*$/$1/g; if ($raw) { printf "%-16s %-12s %5d %-12s %4s %-16s %s\n", $file, $subname, $line, $pack, $type, $name, $event; } else { # Wheee push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}}, $line); } } sub load_pad { my $padlist = shift; my ($namelistav, $vallistav, @namelist, $ix); @pad = (); return if class($padlist) =~ '^(?:SPECIAL|NULL)\z'; ($namelistav,$vallistav) = $padlist->ARRAY; @namelist = $namelistav->ARRAY; for ($ix = 1; $ix < @namelist; $ix++) { my $namesv = $namelist[$ix]; next if class($namesv) eq "SPECIAL"; my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/; $pad[$ix] = ["(lexical)", $type || '?', $name || '?']; } if ($Config{useithreads}) { my (@vallist); @vallist = $vallistav->ARRAY; for ($ix = 1; $ix < @vallist; $ix++) { my $valsv = $vallist[$ix]; next unless class($valsv) eq "GV"; next if class($valsv->STASH) eq 'SPECIAL'; # these pad GVs don't have corresponding names, so same @pad # array can be used without collisions $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME]; } } } sub xref { my $start = shift; my $op; for ($op = $start; $$op; $op = $op->next) { last if $done{$$op}++; warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top; warn peekop($op), "\n" if $debug_op; my $opname = $op->name; if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) { xref($op->other); } elsif ($opname eq "match" || $opname eq "subst") { xref($op->pmreplstart); } elsif ($opname eq "substcont") { xref($op->other->pmreplstart); $op = $op->other; redo; } elsif ($opname eq "enterloop") { xref($op->redoop); xref($op->nextop); xref($op->lastop); } elsif ($opname eq "subst") { xref($op->pmreplstart); } else { no strict 'refs'; my $ppname = "pp_$opname"; &$ppname($op) if defined(&$ppname); } } } sub xref_cv { my $cv = shift; my $pack = $cv->GV->STASH->NAME; $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME; load_pad($cv->PADLIST); xref($cv->START); $subname = "(main)"; } sub xref_object { my $cvref = shift; xref_cv(svref_2object($cvref)); } sub xref_main { $subname = "(main)"; load_pad(comppadlist); xref(main_start); while (@todo) { xref_cv(shift @todo); } } sub pp_nextstate { my $op = shift; $file = $op->file; $line = $op->line; $top = UNKNOWN; } sub pp_padrange { my $op = shift; my $count = $op->private & 127; for my $i (0..$count-1) { $top = $pad[$op->targ + $i]; process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); } } sub pp_padsv { my $op = shift; $top = $pad[$op->targ]; process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); } sub pp_padav { pp_padsv(@_) } sub pp_padhv { pp_padsv(@_) } sub deref { my ($op, $var, $as) = @_; $var->[1] = $as . $var->[1]; process($var, $op->private & OPpOUR_INTRO ? "intro" : "used"); } sub pp_rv2cv { deref(shift, $top, "&"); } sub pp_rv2hv { deref(shift, $top, "%"); } sub pp_rv2sv { deref(shift, $top, "\$"); } sub pp_rv2av { deref(shift, $top, "\@"); } sub pp_rv2gv { deref(shift, $top, "*"); } sub pp_gvsv { my $op = shift; my $gv; if ($Config{useithreads}) { $top = $pad[$op->padix]; $top = UNKNOWN unless $top; $top->[1] = '$'; } else { $gv = $op->gv; $top = [$gv->STASH->NAME, '$', $gv->SAFENAME]; } process($top, $op->private & OPpLVAL_INTRO || $op->private & OPpOUR_INTRO ? "intro" : "used"); } sub pp_gv { my $op = shift; my $gv; if ($Config{useithreads}) { $top = $pad[$op->padix]; $top = UNKNOWN unless $top; $top->[1] = '*'; } else { $gv = $op->gv; if ($gv->FLAGS & SVf_ROK) { # sub ref my $cv = $gv->RV; $top = [$cv->STASH->NAME, '*', B::safename($cv->NAME_HEK)] } else { $top = [$gv->STASH->NAME, '*', $gv->SAFENAME]; } } process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); } sub pp_const { my $op = shift; my $sv = $op->sv; # constant could be in the pad (under useithreads) if ($$sv) { $top = ["?", "", (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? cstring($sv->PV) : "?"]; } else { $top = $pad[$op->targ]; $top = UNKNOWN unless $top; } } sub pp_method { my $op = shift; $top = ["(method)", "->".$top->[1], $top->[2]]; } sub pp_entersub { my $op = shift; if ($top->[1] eq "m") { process($top, "meth"); } else { process($top, "subused"); } $top = UNKNOWN; } # # Stuff for cross referencing definitions of variables and subs # sub B::GV::xref { my $gv = shift; my $cv = $gv->CV; if ($$cv) { #return if $done{$$cv}++; $file = $gv->FILE; $line = $gv->LINE; process([$gv->STASH->NAME, "&", $gv->NAME], "subdef"); push(@todo, $cv); } my $form = $gv->FORM; if ($$form) { return if $done{$$form}++; $file = $gv->FILE; $line = $gv->LINE; process([$gv->STASH->NAME, "", $gv->NAME], "formdef"); } } sub xref_definitions { my ($pack, %exclude); return if $nodefs; $subname = "(definitions)"; foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS strict vars FileHandle Exporter Carp PerlIO::Layer attributes utf8 warnings)) { $exclude{$pack."::"} = 1; } no strict qw(vars refs); walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) }); } sub output { return if $raw; my ($file, $subname, $pack, $name, $ev, $perfile, $persubname, $perpack, $pername, $perev); foreach $file (sort(keys(%table))) { $perfile = $table{$file}; print "File $file\n"; foreach $subname (sort(keys(%$perfile))) { $persubname = $perfile->{$subname}; print " Subroutine $subname\n"; foreach $pack (sort(keys(%$persubname))) { $perpack = $persubname->{$pack}; print " Package $pack\n"; foreach $name (sort(keys(%$perpack))) { $pername = $perpack->{$name}; my @lines; foreach $ev (qw(intro formdef subdef meth subused used)) { $perev = $pername->{$ev}; if (defined($perev) && @$perev) { my $code = $code{$ev}; push(@lines, map("$code$_", @$perev)); } } printf " %-16s %s\n", $name, join(", ", @lines); } } } } } sub compile { my @options = @_; my ($option, $opt, $arg); OPTION: while ($option = shift @options) { if ($option =~ /^-(.)(.*)/) { $opt = $1; $arg = $2; } else { unshift @options, $option; last OPTION; } if ($opt eq "-" && $arg eq "-") { shift @options; last OPTION; } elsif ($opt eq "o") { $arg ||= shift @options; open(STDOUT, '>', $arg) or return "$arg: $!\n"; } elsif ($opt eq "d") { $nodefs = 1; } elsif ($opt eq "r") { $raw = 1; } elsif ($opt eq "D") { $arg ||= shift @options; foreach $arg (split(//, $arg)) { if ($arg eq "o") { B->debug(1); } elsif ($arg eq "O") { $debug_op = 1; } elsif ($arg eq "t") { $debug_top = 1; } } } } if (@options) { return sub { my $objname; xref_definitions(); foreach $objname (@options) { $objname = "main::$objname" unless $objname =~ /::/; eval "xref_object(\\&$objname)"; die "xref_object(\\&$objname) failed: $@" if $@; } output(); } } else { return sub { xref_definitions(); xref_main(); output(); } } } 1; Concise.pm 0000644 00000166142 15125210275 0006477 0 ustar 00 package B::Concise; # Copyright (C) 2000-2003 Stephen McCamant. All rights reserved. # This program is free software; you can redistribute and/or modify it # under the same terms as Perl itself. # Note: we need to keep track of how many use declarations/BEGIN # blocks this module uses, so we can avoid printing them when user # asks for the BEGIN blocks in her program. Update the comments and # the count in concise_specials if you add or delete one. The # -MO=Concise counts as use #1. use strict; # use #2 use warnings; # uses #3 and #4, since warnings uses Carp use Exporter (); # use #5 our $VERSION = "1.004"; our @ISA = qw(Exporter); our @EXPORT_OK = qw( set_style set_style_standard add_callback concise_subref concise_cv concise_main add_style walk_output compile reset_sequence ); our %EXPORT_TAGS = ( io => [qw( walk_output compile reset_sequence )], style => [qw( add_style set_style_standard )], cb => [qw( add_callback )], mech => [qw( concise_subref concise_cv concise_main )], ); # use #6 use B qw(class ppname main_start main_root main_cv cstring svref_2object SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL OPf_STACKED OPpSPLIT_ASSIGN OPpSPLIT_LEX CVf_ANON CVf_LEXICAL CVf_NAMED PAD_FAKELEX_ANON PAD_FAKELEX_MULTI SVf_ROK); my %style = ("terse" => ["(?(#label =>\n)?)(*( )*)#class (#addr) #name (?([#targ])?) " . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n", "(*( )*)goto #class (#addr)\n", "#class pp_#name"], "concise" => ["#hyphseq2 (*( (x( ;)x))*)<#classsym> #exname#arg(?([#targarglife])?)" . "~#flags(?(/#private)?)(?(:#hints)?)(x(;~->#next)x)\n" , " (*( )*) goto #seq\n", "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"], "linenoise" => ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)", "gt_#seq ", "(?(#seq)?)#noise#arg(?([#targarg])?)"], "debug" => ["#class (#addr)\n\top_next\t\t#nextaddr\n\t(?(op_other\t#otheraddr\n\t)?)" . "op_sibling\t#sibaddr\n\t" . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" . "\top_flags\t#flagval\n\top_private\t#privval\t#hintsval\n" . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)" . "(?(\top_sv\t\t#svaddr\n)?)", " GOTO #addr\n", "#addr"], "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT}, $ENV{B_CONCISE_TREE_FORMAT}], ); # Renderings, ie how Concise prints, is controlled by these vars # primary: our $stylename; # selects current style from %style my $order = "basic"; # how optree is walked & printed: basic, exec, tree # rendering mechanics: # these 'formats' are the line-rendering templates # they're updated from %style when $stylename changes my ($format, $gotofmt, $treefmt); # lesser players: my $base = 36; # how <sequence#> is displayed my $big_endian = 1; # more <sequence#> display my $tree_style = 0; # tree-order details my $banner = 1; # print banner before optree is traversed my $do_main = 0; # force printing of main routine my $show_src; # show source code # another factor: can affect all styles! our @callbacks; # allow external management set_style_standard("concise"); my $curcv; my $cop_seq_base; sub set_style { ($format, $gotofmt, $treefmt) = @_; #warn "set_style: deprecated, use set_style_standard instead\n"; # someday die "expecting 3 style-format args\n" unless @_ == 3; } sub add_style { my ($newstyle,@args) = @_; die "style '$newstyle' already exists, choose a new name\n" if exists $style{$newstyle}; die "expecting 3 style-format args\n" unless @args == 3; $style{$newstyle} = [@args]; $stylename = $newstyle; # update rendering state } sub set_style_standard { ($stylename) = @_; # update rendering state die "err: style '$stylename' unknown\n" unless exists $style{$stylename}; set_style(@{$style{$stylename}}); } sub add_callback { push @callbacks, @_; } # output handle, used with all Concise-output printing our $walkHandle; # public for your convenience BEGIN { $walkHandle = \*STDOUT } sub walk_output { # updates $walkHandle my $handle = shift; return $walkHandle unless $handle; # allow use as accessor if (ref $handle eq 'SCALAR') { require Config; die "no perlio in this build, can't call walk_output (\\\$scalar)\n" unless $Config::Config{useperlio}; # in 5.8+, open(FILEHANDLE,MODE,REFERENCE) writes to string open my $tmp, '>', $handle; # but cant re-set existing STDOUT $walkHandle = $tmp; # so use my $tmp as intermediate var return $walkHandle; } my $iotype = ref $handle; die "expecting argument/object that can print\n" unless $iotype eq 'GLOB' or $iotype and $handle->can('print'); $walkHandle = $handle; } sub concise_subref { my($order, $coderef, $name) = @_; my $codeobj = svref_2object($coderef); return concise_stashref(@_) unless ref($codeobj) =~ '^B::(?:CV|FM)\z'; concise_cv_obj($order, $codeobj, $name); } sub concise_stashref { my($order, $h) = @_; my $name = svref_2object($h)->NAME; foreach my $k (sort keys %$h) { next unless defined $h->{$k}; my $coderef = ref $h->{$k} eq 'CODE' ? $h->{$k} : ref\$h->{$k} eq 'GLOB' ? *{$h->{$k}}{CODE} || next : next; reset_sequence(); print "FUNC: *", $name, "::", $k, "\n"; my $codeobj = svref_2object($coderef); next unless ref $codeobj eq 'B::CV'; eval { concise_cv_obj($order, $codeobj, $k) }; warn "err $@ on $codeobj" if $@; } } # This should have been called concise_subref, but it was exported # under this name in versions before 0.56 *concise_cv = \&concise_subref; sub concise_cv_obj { my ($order, $cv, $name) = @_; # name is either a string, or a CODE ref (copy of $cv arg??) $curcv = $cv; if (ref($cv->XSUBANY) =~ /B::(\w+)/) { print $walkHandle "$name is a constant sub, optimized to a $1\n"; return; } if ($cv->XSUB) { print $walkHandle "$name is XS code\n"; return; } if (class($cv->START) eq "NULL") { no strict 'refs'; if (ref $name eq 'CODE') { print $walkHandle "coderef $name has no START\n"; } elsif (exists &$name) { print $walkHandle "$name exists in stash, but has no START\n"; } else { print $walkHandle "$name not in symbol table\n"; } return; } sequence($cv->START); if ($order eq "exec") { walk_exec($cv->START); } elsif ($order eq "basic") { # walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0); my $root = $cv->ROOT; unless (ref $root eq 'B::NULL') { walk_topdown($root, sub { $_[0]->concise($_[1]) }, 0); } else { print $walkHandle "B::NULL encountered doing ROOT on $cv. avoiding disaster\n"; } } else { print $walkHandle tree($cv->ROOT, 0); } } sub concise_main { my($order) = @_; sequence(main_start); $curcv = main_cv; if ($order eq "exec") { return if class(main_start) eq "NULL"; walk_exec(main_start); } elsif ($order eq "tree") { return if class(main_root) eq "NULL"; print $walkHandle tree(main_root, 0); } elsif ($order eq "basic") { return if class(main_root) eq "NULL"; walk_topdown(main_root, sub { $_[0]->concise($_[1]) }, 0); } } sub concise_specials { my($name, $order, @cv_s) = @_; my $i = 1; if ($name eq "BEGIN") { splice(@cv_s, 0, 8); # skip 7 BEGIN blocks in this file. NOW 8 ?? } elsif ($name eq "CHECK") { pop @cv_s; # skip the CHECK block that calls us } for my $cv (@cv_s) { print $walkHandle "$name $i:\n"; $i++; concise_cv_obj($order, $cv, $name); } } my $start_sym = "\e(0"; # "\cN" sometimes also works my $end_sym = "\e(B"; # "\cO" respectively my @tree_decorations = ([" ", "--", "+-", "|-", "| ", "`-", "-", 1], [" ", "-", "+", "+", "|", "`", "", 0], [" ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1], [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0], ); my @render_packs; # collect -stash=<packages> sub compileOpts { # set rendering state from options and args my (@options,@args); if (@_) { @options = grep(/^-/, @_); @args = grep(!/^-/, @_); } for my $o (@options) { # mode/order if ($o eq "-basic") { $order = "basic"; } elsif ($o eq "-exec") { $order = "exec"; } elsif ($o eq "-tree") { $order = "tree"; } # tree-specific elsif ($o eq "-compact") { $tree_style |= 1; } elsif ($o eq "-loose") { $tree_style &= ~1; } elsif ($o eq "-vt") { $tree_style |= 2; } elsif ($o eq "-ascii") { $tree_style &= ~2; } # sequence numbering elsif ($o =~ /^-base(\d+)$/) { $base = $1; } elsif ($o eq "-bigendian") { $big_endian = 1; } elsif ($o eq "-littleendian") { $big_endian = 0; } # miscellaneous, presentation elsif ($o eq "-nobanner") { $banner = 0; } elsif ($o eq "-banner") { $banner = 1; } elsif ($o eq "-main") { $do_main = 1; } elsif ($o eq "-nomain") { $do_main = 0; } elsif ($o eq "-src") { $show_src = 1; } elsif ($o =~ /^-stash=(.*)/) { my $pkg = $1; no strict 'refs'; if (! %{$pkg.'::'}) { eval "require $pkg"; } else { require Config; if (!$Config::Config{usedl} && keys %{$pkg.'::'} == 1 && $pkg->can('bootstrap')) { # It is something that we're statically linked to, but hasn't # yet been used. eval "require $pkg"; } } push @render_packs, $pkg; } # line-style options elsif (exists $style{substr($o, 1)}) { $stylename = substr($o, 1); set_style_standard($stylename); } else { warn "Option $o unrecognized"; } } return (@args); } sub compile { my (@args) = compileOpts(@_); return sub { my @newargs = compileOpts(@_); # accept new rendering options warn "disregarding non-options: @newargs\n" if @newargs; for my $objname (@args) { next unless $objname; # skip null args to avoid noisy responses if ($objname eq "BEGIN") { concise_specials("BEGIN", $order, B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ()); } elsif ($objname eq "INIT") { concise_specials("INIT", $order, B::init_av->isa("B::AV") ? B::init_av->ARRAY : ()); } elsif ($objname eq "CHECK") { concise_specials("CHECK", $order, B::check_av->isa("B::AV") ? B::check_av->ARRAY : ()); } elsif ($objname eq "UNITCHECK") { concise_specials("UNITCHECK", $order, B::unitcheck_av->isa("B::AV") ? B::unitcheck_av->ARRAY : ()); } elsif ($objname eq "END") { concise_specials("END", $order, B::end_av->isa("B::AV") ? B::end_av->ARRAY : ()); } else { # convert function names to subrefs if (ref $objname) { print $walkHandle "B::Concise::compile($objname)\n" if $banner; concise_subref($order, ($objname)x2); next; } else { $objname = "main::" . $objname unless $objname =~ /::/; no strict 'refs'; my $glob = \*$objname; unless (*$glob{CODE} || *$glob{FORMAT}) { print $walkHandle "$objname:\n" if $banner; print $walkHandle "err: unknown function ($objname)\n"; return; } if (my $objref = *$glob{CODE}) { print $walkHandle "$objname:\n" if $banner; concise_subref($order, $objref, $objname); } if (my $objref = *$glob{FORMAT}) { print $walkHandle "$objname (FORMAT):\n" if $banner; concise_subref($order, $objref, $objname); } } } } for my $pkg (@render_packs) { no strict 'refs'; concise_stashref($order, \%{$pkg.'::'}); } if (!@args or $do_main or @render_packs) { print $walkHandle "main program:\n" if $do_main; concise_main($order); } return @args; # something } } my %labels; my $lastnext; # remembers op-chain, used to insert gotos my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|", 'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*", 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#", 'METHOP' => '.', UNOP_AUX => '+'); no warnings 'qw'; # "Possible attempt to put comments..."; use #7 my @linenoise = qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl ` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I -1 -I 1+ I+ 1- I- ** * i* / i/ %$ i% x + i+ - i- . " << >> < i< > i> <= i, >= i. == i= != i! <? i? s< s> s, s. s= s! s? b& b^ b| -0 -i ! ~ a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy uf lf uc lc qm @ [f [ @[ eh vl ky dl ex % ${ @{ uk pk st jn ) )[ a@ a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s} v} ca wa di rs ;; ; ;d }{ { } {} f{ it {l l} rt }l }n }r dm }g }e ^o ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3 g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n> // /= CO'; my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; sub op_flags { # common flags (see BASOP.op_flags in op.h) my($x) = @_; my(@v); push @v, "v" if ($x & 3) == 1; push @v, "s" if ($x & 3) == 2; push @v, "l" if ($x & 3) == 3; push @v, "K" if $x & 4; push @v, "P" if $x & 8; push @v, "R" if $x & 16; push @v, "M" if $x & 32; push @v, "S" if $x & 64; push @v, "*" if $x & 128; return join("", @v); } sub base_n { my $x = shift; return "-" . base_n(-$x) if $x < 0; my $str = ""; do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base); $str = reverse $str if $big_endian; return $str; } my %sequence_num; my $seq_max = 1; sub reset_sequence { # reset the sequence %sequence_num = (); $seq_max = 1; $lastnext = 0; } sub seq { my($op) = @_; return "-" if not exists $sequence_num{$$op}; return base_n($sequence_num{$$op}); } sub walk_topdown { my($op, $sub, $level) = @_; $sub->($op, $level); if ($op->flags & OPf_KIDS) { for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { walk_topdown($kid, $sub, $level + 1); } } if (class($op) eq "PMOP") { my $maybe_root = $op->code_list; if ( ref($maybe_root) and $maybe_root->isa("B::OP") and not $op->flags & OPf_KIDS) { walk_topdown($maybe_root, $sub, $level + 1); } $maybe_root = $op->pmreplroot; if (ref($maybe_root) and $maybe_root->isa("B::OP")) { # It really is the root of the replacement, not something # else stored here for lack of space elsewhere walk_topdown($maybe_root, $sub, $level + 1); } } } sub walklines { my($ar, $level) = @_; for my $l (@$ar) { if (ref($l) eq "ARRAY") { walklines($l, $level + 1); } else { $l->concise($level); } } } sub walk_exec { my($top, $level) = @_; my %opsseen; my @lines; my @todo = ([$top, \@lines]); while (@todo and my($op, $targ) = @{shift @todo}) { for (; $$op; $op = $op->next) { last if $opsseen{$$op}++; push @$targ, $op; my $name = $op->name; if (class($op) eq "LOGOP") { my $ar = []; push @$targ, $ar; push @todo, [$op->other, $ar]; } elsif ($name eq "subst" and $ {$op->pmreplstart}) { my $ar = []; push @$targ, $ar; push @todo, [$op->pmreplstart, $ar]; } elsif ($name =~ /^enter(loop|iter)$/) { $labels{${$op->nextop}} = "NEXT"; $labels{${$op->lastop}} = "LAST"; $labels{${$op->redoop}} = "REDO"; } } } walklines(\@lines, 0); } # The structure of this routine is purposely modeled after op.c's peep() sub sequence { my($op) = @_; my $oldop = 0; return if class($op) eq "NULL" or exists $sequence_num{$$op}; for (; $$op; $op = $op->next) { last if exists $sequence_num{$$op}; my $name = $op->name; $sequence_num{$$op} = $seq_max++; if (class($op) eq "LOGOP") { sequence($op->other); } elsif (class($op) eq "LOOP") { sequence($op->redoop); sequence( $op->nextop); sequence($op->lastop); } elsif ($name eq "subst" and $ {$op->pmreplstart}) { sequence($op->pmreplstart); } $oldop = $op; } } sub fmt_line { # generate text-line for op. my($hr, $op, $text, $level) = @_; $_->($hr, $op, \$text, \$level, $stylename) for @callbacks; return '' if $hr->{SKIP}; # suppress line if a callback said so return '' if $hr->{goto} and $hr->{goto} eq '-'; # no goto nowhere # spec: (?(text1#varText2)?) $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/ $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg; # spec: (x(exec_text;basic_text)x) $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs; # spec: (*(text)*) $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs; # spec: (*(text1;text2)*) $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs; # convert #Var to tag=>val form: Var\t#var $text =~ s/\#([A-Z][a-z]+)(\d+)?/\t\u$1\t\L#$1$2/gs; # spec: #varN $text =~ s/\#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg; $text =~ s/\#([a-zA-Z]+)/$hr->{$1}/eg; # populate #var's $text =~ s/[ \t]*~+[ \t]*/ /g; # squeeze tildes $text = "# $hr->{src}\n$text" if $show_src and $hr->{src}; chomp $text; return "$text\n" if $text ne "" and $order ne "tree"; return $text; # suppress empty lines } # use require rather than use here to avoid disturbing tests that dump # BEGIN blocks require B::Op_private; our %hints; # used to display each COP's op_hints values # strict refs, subs, vars @hints{0x2,0x200,0x400,0x20,0x40,0x80} = ('$', '&', '*', 'x$', 'x&', 'x*'); # integers, locale, bytes @hints{0x1,0x4,0x8,0x10} = ('i', 'l', 'b'); # block scope, localise %^H, $^OPEN (in), $^OPEN (out) @hints{0x100,0x20000,0x40000,0x80000} = ('{','%','<','>'); # overload new integer, float, binary, string, re @hints{0x1000,0x2000,0x4000,0x8000,0x10000} = ('I', 'F', 'B', 'S', 'R'); # taint and eval @hints{0x100000,0x200000} = ('T', 'E'); # filetest access, use utf8, unicode_strings feature @hints{0x400000,0x800000,0x800} = ('X', 'U', 'us'); # pick up the feature hints constants. # Note that we're relying on non-API parts of feature.pm, # but its less naughty than just blindly copying those constants into # this src file. # require feature; sub hints_flags { my($x) = @_; my @s; for my $flag (sort {$b <=> $a} keys %hints) { if ($hints{$flag} and $x & $flag and $x >= $flag) { $x -= $flag; push @s, $hints{$flag}; } } if ($x & $feature::hint_mask) { push @s, "fea=" . (($x & $feature::hint_mask) >> $feature::hint_shift); $x &= ~$feature::hint_mask; } push @s, sprintf "0x%x", $x if $x; return join(",", @s); } # return a string like 'LVINTRO,1' for the op $name with op_private # value $x sub private_flags { my($name, $x) = @_; my $entry = $B::Op_private::bits{$name}; return $x ? "$x" : '' unless $entry; my @flags; my $bit; for ($bit = 7; $bit >= 0; $bit--) { next unless exists $entry->{$bit}; my $e = $entry->{$bit}; if (ref($e) eq 'HASH') { # bit field my ($bitmin, $bitmax, $bitmask, $enum, $label) = @{$e}{qw(bitmin bitmax bitmask enum label)}; $bit = $bitmin; next if defined $label && $label eq '-'; # display as raw number my $val = $x & $bitmask; $x &= ~$bitmask; $val >>= $bitmin; if (defined $enum) { # try to convert numeric $val into symbolic my @enum = @$enum; while (@enum) { my $ix = shift @enum; my $name = shift @enum; my $label = shift @enum; if ($val == $ix) { $val = $label; last; } } } next if $val eq '0'; # don't display anonymous zero values push @flags, defined $label ? "$label=$val" : $val; } else { # flag bit my $label = $B::Op_private::labels{$e}; next if defined $label && $label eq '-'; # display as raw number if ($x & (1<<$bit)) { $x -= (1<<$bit); push @flags, $label; } } } push @flags, $x if $x; # display unknown bits numerically return join ",", @flags; } sub concise_sv { my($sv, $hr, $preferpv) = @_; $hr->{svclass} = class($sv); $hr->{svclass} = "UV" if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV; Carp::cluck("bad concise_sv: $sv") unless $sv and $$sv; $hr->{svaddr} = sprintf("%#x", $$sv); if ($hr->{svclass} eq "GV" && $sv->isGV_with_GP()) { my $gv = $sv; my $stash = $gv->STASH; if (class($stash) eq "SPECIAL") { $stash = "<none>"; } else { $stash = $stash->NAME; } if ($stash eq "main") { $stash = ""; } else { $stash = $stash . "::"; } $hr->{svval} = "*$stash" . $gv->SAFENAME; return "*$stash" . $gv->SAFENAME; } else { while (class($sv) eq "IV" && $sv->FLAGS & SVf_ROK) { $hr->{svval} .= "\\"; $sv = $sv->RV; } if (class($sv) eq "SPECIAL") { $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no", '', '', '', "sv_zero"]->[$$sv]; } elsif ($preferpv && ($sv->FLAGS & SVf_POK)) { $hr->{svval} .= cstring($sv->PV); } elsif ($sv->FLAGS & SVf_NOK) { $hr->{svval} .= $sv->NV; } elsif ($sv->FLAGS & SVf_IOK) { $hr->{svval} .= $sv->int_value; } elsif ($sv->FLAGS & SVf_POK) { $hr->{svval} .= cstring($sv->PV); } elsif (class($sv) eq "HV") { $hr->{svval} .= 'HASH'; } elsif (class($sv) eq "AV") { $hr->{svval} .= 'ARRAY'; } elsif (class($sv) eq "CV") { if ($sv->CvFLAGS & CVf_ANON) { $hr->{svval} .= 'CODE'; } elsif ($sv->CvFLAGS & CVf_NAMED) { $hr->{svval} .= "&"; unless ($sv->CvFLAGS & CVf_LEXICAL) { my $stash = $sv->STASH; unless (class($stash) eq "SPECIAL") { $hr->{svval} .= $stash->NAME . "::"; } } $hr->{svval} .= $sv->NAME_HEK; } else { $hr->{svval} .= "&"; $sv = $sv->GV; my $stash = $sv->STASH; unless (class($stash) eq "SPECIAL") { $hr->{svval} .= $stash->NAME . "::"; } $hr->{svval} .= $sv->SAFENAME; } } $hr->{svval} = 'undef' unless defined $hr->{svval}; my $out = $hr->{svclass}; return $out .= " $hr->{svval}" ; } } my %srclines; sub fill_srclines { my $fullnm = shift; if ($fullnm eq '-e') { $srclines{$fullnm} = [ $fullnm, "-src not supported for -e" ]; return; } open (my $fh, '<', $fullnm) or warn "# $fullnm: $!, (chdirs not supported by this feature yet)\n" and return; my @l = <$fh>; chomp @l; unshift @l, $fullnm; # like @{_<$fullnm} in debug, array starts at 1 $srclines{$fullnm} = \@l; } # Given a pad target, return the pad var's name and cop range / # fakeness, or failing that, its target number. # e.g. # ('$i', '$i:5,7') # or # ('$i', '$i:fake:a') # or # ('t5', 't5') sub padname { my ($targ) = @_; my ($targarg, $targarglife); my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$targ]; if (defined $padname and class($padname) ne "SPECIAL" and $padname->LEN) { $targarg = $padname->PVX; if ($padname->FLAGS & SVf_FAKE) { # These changes relate to the jumbo closure fix. # See changes 19939 and 20005 my $fake = ''; $fake .= 'a' if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON; $fake .= 'm' if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI; $fake .= ':' . $padname->PARENT_PAD_INDEX if $curcv->CvFLAGS & CVf_ANON; $targarglife = "$targarg:FAKE:$fake"; } else { my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base; my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base; $finish = "end" if $finish == 999999999 - $cop_seq_base; $targarglife = "$targarg:$intro,$finish"; } } else { $targarglife = $targarg = "t" . $targ; } return $targarg, $targarglife; } sub concise_op { my ($op, $level, $format) = @_; my %h; $h{exname} = $h{name} = $op->name; $h{NAME} = uc $h{name}; $h{class} = class($op); $h{extarg} = $h{targ} = $op->targ; $h{extarg} = "" unless $h{extarg}; $h{privval} = $op->private; # for null ops, targ holds the old type my $origname = $h{name} eq "null" && $h{targ} ? substr(ppname($h{targ}), 3) : $h{name}; $h{private} = private_flags($origname, $op->private); if ($op->folded) { $h{private} &&= "$h{private},"; $h{private} .= "FOLD"; } if ($h{name} ne $origname) { # a null op $h{exname} = "ex-$origname"; $h{extarg} = ""; } elsif ($h{private} =~ /\bREFC\b/) { # targ holds a reference count my $refs = "ref" . ($h{targ} != 1 ? "s" : ""); $h{targarglife} = $h{targarg} = "$h{targ} $refs"; } elsif ($h{targ}) { my $count = $h{name} eq 'padrange' ? ($op->private & $B::Op_private::defines{'OPpPADRANGE_COUNTMASK'}) : 1; my (@targarg, @targarglife); for my $i (0..$count-1) { my ($targarg, $targarglife) = padname($h{targ} + $i); push @targarg, $targarg; push @targarglife, $targarglife; } $h{targarg} = join '; ', @targarg; $h{targarglife} = join '; ', @targarglife; } $h{arg} = ""; $h{svclass} = $h{svaddr} = $h{svval} = ""; if ($h{class} eq "PMOP") { my $extra = ''; my $precomp = $op->precomp; if (defined $precomp) { $precomp = cstring($precomp); # Escape literal control sequences $precomp = "/$precomp/"; } else { $precomp = ""; } if ($op->name eq 'subst') { if (class($op->pmreplstart) ne "NULL") { undef $lastnext; $extra = " replstart->" . seq($op->pmreplstart); } } elsif ($op->name eq 'split') { if ( ($op->private & OPpSPLIT_ASSIGN) # @array = split && (not $op->flags & OPf_STACKED)) # @{expr} = split { # with C<@array = split(/pat/, str);>, # array is stored in /pat/'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) if ($op->private & $B::Op_private::defines{'OPpSPLIT_LEX'}) { my $off = $op->pmreplroot; # union with op_pmtargetoff my ($name, $full) = padname($off); $extra = " => $full"; } else { # union with op_pmtargetoff, op_pmtargetgv my $gv = $op->pmreplroot; if (!ref($gv)) { # the value is actually a pad offset $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$gv]->NAME; } else { # unthreaded: its a GV $gv = $gv->NAME; } $extra = " => \@$gv"; } } } $h{arg} = "($precomp$extra)"; } elsif ($h{class} eq "PVOP" and $h{name} !~ '^transr?\z') { $h{arg} = '("' . $op->pv . '")'; $h{svval} = '"' . $op->pv . '"'; } elsif ($h{class} eq "COP") { my $label = $op->label; $h{coplabel} = $label; $label = $label ? "$label: " : ""; my $loc = $op->file; my $pathnm = $loc; $loc =~ s[.*/][]; my $ln = $op->line; $loc .= ":$ln"; my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base); $h{arg} = "($label$stash $cseq $loc)"; if ($show_src) { fill_srclines($pathnm) unless exists $srclines{$pathnm}; my $line = $srclines{$pathnm}[$ln] // "-src unavailable under -e"; $h{src} = "$ln: $line"; } } elsif ($h{class} eq "LOOP") { $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop) . " redo->" . seq($op->redoop) . ")"; } elsif ($h{class} eq "LOGOP") { undef $lastnext; $h{arg} = "(other->" . seq($op->other) . ")"; $h{otheraddr} = sprintf("%#x", $ {$op->other}); if ($h{name} eq "argdefelem") { # targ used for element index $h{targarglife} = $h{targarg} = ""; $h{arg} .= "[" . $op->targ . "]"; } } elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") { unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) { my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix; if ($h{class} eq "PADOP" or !${$op->sv}) { my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx]; $h{arg} = "[" . concise_sv($sv, \%h, 0) . "]"; $h{targarglife} = $h{targarg} = ""; } else { $h{arg} = "(" . concise_sv($op->sv, \%h, 0) . ")"; } } } elsif ($h{class} eq "METHOP") { my $prefix = ''; if ($h{name} eq 'method_redir' or $h{name} eq 'method_redir_super') { my $rclass_sv = $op->rclass; $rclass_sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$rclass_sv] unless ref $rclass_sv; $prefix .= 'PACKAGE "'.$rclass_sv->PV.'", '; } if ($h{name} ne "method") { if (${$op->meth_sv}) { $h{arg} = "($prefix" . concise_sv($op->meth_sv, \%h, 1) . ")"; } else { my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->targ]; $h{arg} = "[$prefix" . concise_sv($sv, \%h, 1) . "]"; $h{targarglife} = $h{targarg} = ""; } } } elsif ($h{class} eq "UNOP_AUX") { $h{arg} = "(" . $op->string($curcv) . ")"; } $h{seq} = $h{hyphseq} = seq($op); $h{seq} = "" if $h{seq} eq "-"; $h{opt} = $op->opt; $h{label} = $labels{$$op}; $h{next} = $op->next; $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next}); $h{nextaddr} = sprintf("%#x", $ {$op->next}); $h{sibaddr} = sprintf("%#x", $ {$op->sibling}); $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first"); $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last"); $h{classsym} = $opclass{$h{class}}; $h{flagval} = $op->flags; $h{flags} = op_flags($op->flags); if ($op->can("hints")) { $h{hintsval} = $op->hints; $h{hints} = hints_flags($h{hintsval}); } else { $h{hintsval} = $h{hints} = ''; } $h{addr} = sprintf("%#x", $$op); $h{typenum} = $op->type; $h{noise} = $linenoise[$op->type]; return fmt_line(\%h, $op, $format, $level); } sub B::OP::concise { my($op, $level) = @_; if ($order eq "exec" and $lastnext and $$lastnext != $$op) { # insert a 'goto' line my $synth = {"seq" => seq($lastnext), "class" => class($lastnext), "addr" => sprintf("%#x", $$lastnext), "goto" => seq($lastnext), # simplify goto '-' removal }; print $walkHandle fmt_line($synth, $op, $gotofmt, $level+1); } $lastnext = $op->next; print $walkHandle concise_op($op, $level, $format); } # B::OP::terse (see Terse.pm) now just calls this sub b_terse { my($op, $level) = @_; # This isn't necessarily right, but there's no easy way to get # from an OP to the right CV. This is a limitation of the # ->terse() interface style, and there isn't much to do about # it. In particular, we can die in concise_op if the main pad # isn't long enough, or has the wrong kind of entries, compared to # the pad a sub was compiled with. The fix for that would be to # make a backwards compatible "terse" format that never even # looked at the pad, just like the old B::Terse. I don't think # that's worth the effort, though. $curcv = main_cv unless $curcv; if ($order eq "exec" and $lastnext and $$lastnext != $$op) { # insert a 'goto' my $h = {"seq" => seq($lastnext), "class" => class($lastnext), "addr" => sprintf("%#x", $$lastnext)}; print # $walkHandle fmt_line($h, $op, $style{"terse"}[1], $level+1); } $lastnext = $op->next; print # $walkHandle concise_op($op, $level, $style{"terse"}[0]); } sub tree { my $op = shift; my $level = shift; my $style = $tree_decorations[$tree_style]; my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style; my $name = concise_op($op, $level, $treefmt); if (not $op->flags & OPf_KIDS) { return $name . "\n"; } my @lines; for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { push @lines, tree($kid, $level+1); } my $i; for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) { $lines[$i] = $space . $lines[$i]; } if ($i > 0) { $lines[$i] = $last . $lines[$i]; while ($i-- > 1) { if (substr($lines[$i], 0, 1) eq " ") { $lines[$i] = $nokid . $lines[$i]; } else { $lines[$i] = $kid . $lines[$i]; } } $lines[$i] = $kids . $lines[$i]; } else { $lines[0] = $single . $lines[0]; } return("$name$lead" . shift @lines, map(" " x (length($name)+$size) . $_, @lines)); } # *** Warning: fragile kludge ahead *** # Because the B::* modules run in the same interpreter as the code # they're compiling, their presence tends to distort the view we have of # the code we're looking at. In particular, perl gives sequence numbers # to COPs. If the program we're looking at were run on its own, this # would start at 1. Because all of B::Concise and all the modules it # uses are compiled first, though, by the time we get to the user's # program the sequence number is already pretty high, which could be # distracting if you're trying to tell OPs apart. Therefore we'd like to # subtract an offset from all the sequence numbers we display, to # restore the simpler view of the world. The trick is to know what that # offset will be, when we're still compiling B::Concise! If we # hardcoded a value, it would have to change every time B::Concise or # other modules we use do. To help a little, what we do here is compile # a little code at the end of the module, and compute the base sequence # number for the user's program as being a small offset later, so all we # have to worry about are changes in the offset. # When you say "perl -MO=Concise -e '$a'", the output should look like: # 4 <@> leave[t1] vKP/REFC ->(end) # 1 <0> enter ->2 #^ smallest OP sequence number should be 1 # 2 <;> nextstate(main 1 -e:1) v ->3 # ^ smallest COP sequence number should be 1 # - <1> ex-rv2sv vK/1 ->4 # 3 <$> gvsv(*a) s ->4 # If the second of the marked numbers there isn't 1, it means you need # to update the corresponding magic number in the next line. # Remember, this needs to stay the last things in the module. my $cop_seq_mnum = 12; $cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum; 1; __END__ =head1 NAME B::Concise - Walk Perl syntax tree, printing concise info about ops =head1 SYNOPSIS perl -MO=Concise[,OPTIONS] foo.pl use B::Concise qw(set_style add_callback); =head1 DESCRIPTION This compiler backend prints the internal OPs of a Perl program's syntax tree in one of several space-efficient text formats suitable for debugging the inner workings of perl or other compiler backends. It can print OPs in the order they appear in the OP tree, in the order they will execute, or in a text approximation to their tree structure, and the format of the information displayed is customizable. Its function is similar to that of perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more sophisticated and flexible. =head1 EXAMPLE Here's two outputs (or 'renderings'), using the -exec and -basic (i.e. default) formatting conventions on the same code snippet. % perl -MO=Concise,-exec -e '$a = $b + 42' 1 <0> enter 2 <;> nextstate(main 1 -e:1) v 3 <#> gvsv[*b] s 4 <$> const[IV 42] s * 5 <2> add[t3] sK/2 6 <#> gvsv[*a] s 7 <2> sassign vKS/2 8 <@> leave[1 ref] vKP/REFC In this -exec rendering, each opcode is executed in the order shown. The add opcode, marked with '*', is discussed in more detail. The 1st column is the op's sequence number, starting at 1, and is displayed in base 36 by default. Here they're purely linear; the sequences are very helpful when looking at code with loops and branches. The symbol between angle brackets indicates the op's type, for example; <2> is a BINOP, <@> a LISTOP, and <#> is a PADOP, which is used in threaded perls. (see L</"OP class abbreviations">). The opname, as in B<'add[t1]'>, may be followed by op-specific information in parentheses or brackets (ex B<'[t1]'>). The op-flags (ex B<'sK/2'>) are described in (L</"OP flags abbreviations">). % perl -MO=Concise -e '$a = $b + 42' 8 <@> leave[1 ref] vKP/REFC ->(end) 1 <0> enter ->2 2 <;> nextstate(main 1 -e:1) v ->3 7 <2> sassign vKS/2 ->8 * 5 <2> add[t1] sK/2 ->6 - <1> ex-rv2sv sK/1 ->4 3 <$> gvsv(*b) s ->4 4 <$> const(IV 42) s ->5 - <1> ex-rv2sv sKRM*/1 ->7 6 <$> gvsv(*a) s ->7 The default rendering is top-down, so they're not in execution order. This form reflects the way the stack is used to parse and evaluate expressions; the add operates on the two terms below it in the tree. Nullops appear as C<ex-opname>, where I<opname> is an op that has been optimized away by perl. They're displayed with a sequence-number of '-', because they are not executed (they don't appear in previous example), they're printed here because they reflect the parse. The arrow points to the sequence number of the next op; they're not displayed in -exec mode, for obvious reasons. Note that because this rendering was done on a non-threaded perl, the PADOPs in the previous examples are now SVOPs, and some (but not all) of the square brackets have been replaced by round ones. This is a subtle feature to provide some visual distinction between renderings on threaded and un-threaded perls. =head1 OPTIONS Arguments that don't start with a hyphen are taken to be the names of subroutines or formats to render; if no such functions are specified, the main body of the program (outside any subroutines, and not including use'd or require'd files) is rendered. Passing C<BEGIN>, C<UNITCHECK>, C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding special blocks to be printed. Arguments must follow options. Options affect how things are rendered (ie printed). They're presented here by their visual effect, 1st being strongest. They're grouped according to how they interrelate; within each group the options are mutually exclusive (unless otherwise stated). =head2 Options for Opcode Ordering These options control the 'vertical display' of opcodes. The display 'order' is also called 'mode' elsewhere in this document. =over 4 =item B<-basic> Print OPs in the order they appear in the OP tree (a preorder traversal, starting at the root). The indentation of each OP shows its level in the tree, and the '->' at the end of the line indicates the next opcode in execution order. This mode is the default, so the flag is included simply for completeness. =item B<-exec> Print OPs in the order they would normally execute (for the majority of constructs this is a postorder traversal of the tree, ending at the root). In most cases the OP that usually follows a given OP will appear directly below it; alternate paths are shown by indentation. In cases like loops when control jumps out of a linear path, a 'goto' line is generated. =item B<-tree> Print OPs in a text approximation of a tree, with the root of the tree at the left and 'left-to-right' order of children transformed into 'top-to-bottom'. Because this mode grows both to the right and down, it isn't suitable for large programs (unless you have a very wide terminal). =back =head2 Options for Line-Style These options select the line-style (or just style) used to render each opcode, and dictates what info is actually printed into each line. =over 4 =item B<-concise> Use the author's favorite set of formatting conventions. This is the default, of course. =item B<-terse> Use formatting conventions that emulate the output of B<B::Terse>. The basic mode is almost indistinguishable from the real B<B::Terse>, and the exec mode looks very similar, but is in a more logical order and lacks curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode is only vaguely reminiscent of B<B::Terse>. =item B<-linenoise> Use formatting conventions in which the name of each OP, rather than being written out in full, is represented by a one- or two-character abbreviation. This is mainly a joke. =item B<-debug> Use formatting conventions reminiscent of CPAN module B<B::Debug>; these aren't very concise at all. =item B<-env> Use formatting conventions read from the environment variables C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>. =back =head2 Options for tree-specific formatting =over 4 =item B<-compact> Use a tree format in which the minimum amount of space is used for the lines connecting nodes (one character in most cases). This squeezes out a few precious columns of screen real estate. =item B<-loose> Use a tree format that uses longer edges to separate OP nodes. This format tends to look better than the compact one, especially in ASCII, and is the default. =item B<-vt> Use tree connecting characters drawn from the VT100 line-drawing set. This looks better if your terminal supports it. =item B<-ascii> Draw the tree with standard ASCII characters like C<+> and C<|>. These don't look as clean as the VT100 characters, but they'll work with almost any terminal (or the horizontal scrolling mode of less(1)) and are suitable for text documentation or email. This is the default. =back These are pairwise exclusive, i.e. compact or loose, vt or ascii. =head2 Options controlling sequence numbering =over 4 =item B<-base>I<n> Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit for 37 will be 'A', and so on until 62. Values greater than 62 are not currently supported. The default is 36. =item B<-bigendian> Print sequence numbers with the most significant digit first. This is the usual convention for Arabic numerals, and the default. =item B<-littleendian> Print sequence numbers with the least significant digit first. This is obviously mutually exclusive with bigendian. =back =head2 Other options =over 4 =item B<-src> With this option, the rendering of each statement (starting with the nextstate OP) will be preceded by the 1st line of source code that generates it. For example: 1 <0> enter # 1: my $i; 2 <;> nextstate(main 1 junk.pl:1) v:{ 3 <0> padsv[$i:1,10] vM/LVINTRO # 3: for $i (0..9) { 4 <;> nextstate(main 3 junk.pl:3) v:{ 5 <0> pushmark s 6 <$> const[IV 0] s 7 <$> const[IV 9] s 8 <{> enteriter(next->j last->m redo->9)[$i:1,10] lKS k <0> iter s l <|> and(other->9) vK/1 # 4: print "line "; 9 <;> nextstate(main 2 junk.pl:4) v a <0> pushmark s b <$> const[PV "line "] s c <@> print vK # 5: print "$i\n"; ... =item B<-stash="somepackage"> With this, "somepackage" will be required, then the stash is inspected, and each function is rendered. =back The following options are pairwise exclusive. =over 4 =item B<-main> Include the main program in the output, even if subroutines were also specified. This rendering is normally suppressed when a subroutine name or reference is given. =item B<-nomain> This restores the default behavior after you've changed it with '-main' (it's not normally needed). If no subroutine name/ref is given, main is rendered, regardless of this flag. =item B<-nobanner> Renderings usually include a banner line identifying the function name or stringified subref. This suppresses the printing of the banner. TBC: Remove the stringified coderef; while it provides a 'cookie' for each function rendered, the cookies used should be 1,2,3.. not a random hex-address. It also complicates string comparison of two different trees. =item B<-banner> restores default banner behavior. =item B<-banneris> => subref TBC: a hookpoint (and an option to set it) for a user-supplied function to produce a banner appropriate for users needs. It's not ideal, because the rendering-state variables, which are a natural candidate for use in concise.t, are unavailable to the user. =back =head2 Option Stickiness If you invoke Concise more than once in a program, you should know that the options are 'sticky'. This means that the options you provide in the first call will be remembered for the 2nd call, unless you re-specify or change them. =head1 ABBREVIATIONS The concise style uses symbols to convey maximum info with minimal clutter (like hex addresses). With just a little practice, you can start to see the flowers, not just the branches, in the trees. =head2 OP class abbreviations These symbols appear before the op-name, and indicate the B:: namespace that represents the ops in your Perl code. 0 OP (aka BASEOP) An OP with no children 1 UNOP An OP with one child + UNOP_AUX A UNOP with auxillary fields 2 BINOP An OP with two children | LOGOP A control branch OP @ LISTOP An OP that could have lots of children / PMOP An OP with a regular expression $ SVOP An OP with an SV " PVOP An OP with a string { LOOP An OP that holds pointers for a loop ; COP An OP that marks the start of a statement # PADOP An OP with a GV on the pad . METHOP An OP with method call info =head2 OP flags abbreviations OP flags are either public or private. The public flags alter the behavior of each opcode in consistent ways, and are represented by 0 or more single characters. v OPf_WANT_VOID Want nothing (void context) s OPf_WANT_SCALAR Want single value (scalar context) l OPf_WANT_LIST Want list of any length (list context) Want is unknown K OPf_KIDS There is a firstborn child. P OPf_PARENS This operator was parenthesized. (Or block needs explicit scope entry.) R OPf_REF Certified reference. (Return container, not containee). M OPf_MOD Will modify (lvalue). S OPf_STACKED Some arg is arriving on the stack. * OPf_SPECIAL Do something weird for this op (see op.h) Private flags, if any are set for an opcode, are displayed after a '/' 8 <@> leave[1 ref] vKP/REFC ->(end) 7 <2> sassign vKS/2 ->8 They're opcode specific, and occur less often than the public ones, so they're represented by short mnemonics instead of single-chars; see B::Op_private and F<regen/op_private> for more details. =head1 FORMATTING SPECIFICATIONS For each line-style ('concise', 'terse', 'linenoise', etc.) there are 3 format-specs which control how OPs are rendered. The first is the 'default' format, which is used in both basic and exec modes to print all opcodes. The 2nd, goto-format, is used in exec mode when branches are encountered. They're not real opcodes, and are inserted to look like a closing curly brace. The tree-format is tree specific. When a line is rendered, the correct format-spec is copied and scanned for the following items; data is substituted in, and other manipulations like basic indenting are done, for each opcode rendered. There are 3 kinds of items that may be populated; special patterns, #vars, and literal text, which is copied verbatim. (Yes, it's a set of s///g steps.) =head2 Special Patterns These items are the primitives used to perform indenting, and to select text from amongst alternatives. =over 4 =item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)> Generates I<exec_text> in exec mode, or I<basic_text> in basic mode. =item B<(*(>I<text>B<)*)> Generates one copy of I<text> for each indentation level. =item B<(*(>I<text1>B<;>I<text2>B<)*)> Generates one fewer copies of I<text1> than the indentation level, followed by one copy of I<text2> if the indentation level is more than 0. =item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)> If the value of I<var> is true (not empty or zero), generates the value of I<var> surrounded by I<text1> and I<Text2>, otherwise nothing. =item B<~> Any number of tildes and surrounding whitespace will be collapsed to a single space. =back =head2 # Variables These #vars represent opcode properties that you may want as part of your rendering. The '#' is intended as a private sigil; a #var's value is interpolated into the style-line, much like "read $this". These vars take 3 forms: =over 4 =item B<#>I<var> A property named 'var' is assumed to exist for the opcodes, and is interpolated into the rendering. =item B<#>I<var>I<N> Generates the value of I<var>, left justified to fill I<N> spaces. Note that this means while you can have properties 'foo' and 'foo2', you cannot render 'foo2', but you could with 'foo2a'. You would be wise not to rely on this behavior going forward ;-) =item B<#>I<Var> This ucfirst form of #var generates a tag-value form of itself for display; it converts '#Var' into a 'Var => #var' style, which is then handled as described above. (Imp-note: #Vars cannot be used for conditional-fills, because the => #var transform is done after the check for #Var's value). =back The following variables are 'defined' by B::Concise; when they are used in a style, their respective values are plugged into the rendering of each opcode. Only some of these are used by the standard styles, the others are provided for you to delve into optree mechanics, should you wish to add a new style (see L</add_style> below) that uses them. You can also add new ones using L</add_callback>. =over 4 =item B<#addr> The address of the OP, in hexadecimal. =item B<#arg> The OP-specific information of the OP (such as the SV for an SVOP, the non-local exit pointers for a LOOP, etc.) enclosed in parentheses. =item B<#class> The B-determined class of the OP, in all caps. =item B<#classsym> A single symbol abbreviating the class of the OP. =item B<#coplabel> The label of the statement or block the OP is the start of, if any. =item B<#exname> The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo. =item B<#extarg> The target of the OP, or nothing for a nulled OP. =item B<#firstaddr> The address of the OP's first child, in hexadecimal. =item B<#flags> The OP's flags, abbreviated as a series of symbols. =item B<#flagval> The numeric value of the OP's flags. =item B<#hints> The COP's hint flags, rendered with abbreviated names if possible. An empty string if this is not a COP. Here are the symbols used: $ strict refs & strict subs * strict vars x$ explicit use/no strict refs x& explicit use/no strict subs x* explicit use/no strict vars i integers l locale b bytes { block scope % localise %^H < open in > open out I overload int F overload float B overload binary S overload string R overload re T taint E eval X filetest access U utf-8 us use feature 'unicode_strings' fea=NNN feature bundle number =item B<#hintsval> The numeric value of the COP's hint flags, or an empty string if this is not a COP. =item B<#hyphseq> The sequence number of the OP, or a hyphen if it doesn't have one. =item B<#label> 'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec mode, or empty otherwise. =item B<#lastaddr> The address of the OP's last child, in hexadecimal. =item B<#name> The OP's name. =item B<#NAME> The OP's name, in all caps. =item B<#next> The sequence number of the OP's next OP. =item B<#nextaddr> The address of the OP's next OP, in hexadecimal. =item B<#noise> A one- or two-character abbreviation for the OP's name. =item B<#private> The OP's private flags, rendered with abbreviated names if possible. =item B<#privval> The numeric value of the OP's private flags. =item B<#seq> The sequence number of the OP. Note that this is a sequence number generated by B::Concise. =item B<#opt> Whether or not the op has been optimized by the peephole optimizer. =item B<#sibaddr> The address of the OP's next youngest sibling, in hexadecimal. =item B<#svaddr> The address of the OP's SV, if it has an SV, in hexadecimal. =item B<#svclass> The class of the OP's SV, if it has one, in all caps (e.g., 'IV'). =item B<#svval> The value of the OP's SV, if it has one, in a short human-readable format. =item B<#targ> The numeric value of the OP's targ. =item B<#targarg> The name of the variable the OP's targ refers to, if any, otherwise the letter t followed by the OP's targ in decimal. =item B<#targarglife> Same as B<#targarg>, but followed by the COP sequence numbers that delimit the variable's lifetime (or 'end' for a variable in an open scope) for a variable. =item B<#typenum> The numeric value of the OP's type, in decimal. =back =head1 One-Liner Command tips =over 4 =item perl -MO=Concise,bar foo.pl Renders only bar() from foo.pl. To see main, drop the ',bar'. To see both, add ',-main' =item perl -MDigest::MD5=md5 -MO=Concise,md5 -e1 Identifies md5 as an XS function. The export is needed so that BC can find it in main. =item perl -MPOSIX -MO=Concise,_POSIX_ARG_MAX -e1 Identifies _POSIX_ARG_MAX as a constant sub, optimized to an IV. Although POSIX isn't entirely consistent across platforms, this is likely to be present in virtually all of them. =item perl -MPOSIX -MO=Concise,a -e 'print _POSIX_SAVED_IDS' This renders a print statement, which includes a call to the function. It's identical to rendering a file with a use call and that single statement, except for the filename which appears in the nextstate ops. =item perl -MPOSIX -MO=Concise,a -e 'sub a{_POSIX_SAVED_IDS}' This is B<very> similar to previous, only the first two ops differ. This subroutine rendering is more representative, insofar as a single main program will have many subs. =item perl -MB::Concise -e 'B::Concise::compile("-exec","-src", \%B::Concise::)->()' This renders all functions in the B::Concise package with the source lines. It eschews the O framework so that the stashref can be passed directly to B::Concise::compile(). See -stash option for a more convenient way to render a package. =back =head1 Using B::Concise outside of the O framework The common (and original) usage of B::Concise was for command-line renderings of simple code, as given in EXAMPLE. But you can also use B<B::Concise> from your code, and call compile() directly, and repeatedly. By doing so, you can avoid the compile-time only operation of O.pm, and even use the debugger to step through B::Concise::compile() itself. Once you're doing this, you may alter Concise output by adding new rendering styles, and by optionally adding callback routines which populate new variables, if such were referenced from those (just added) styles. =head2 Example: Altering Concise Renderings use B::Concise qw(set_style add_callback); add_style($yourStyleName => $defaultfmt, $gotofmt, $treefmt); add_callback ( sub { my ($h, $op, $format, $level, $stylename) = @_; $h->{variable} = some_func($op); }); $walker = B::Concise::compile(@options,@subnames,@subrefs); $walker->(); =head2 set_style() B<set_style> accepts 3 arguments, and updates the three format-specs comprising a line-style (basic-exec, goto, tree). It has one minor drawback though; it doesn't register the style under a new name. This can become an issue if you render more than once and switch styles. Thus you may prefer to use add_style() and/or set_style_standard() instead. =head2 set_style_standard($name) This restores one of the standard line-styles: C<terse>, C<concise>, C<linenoise>, C<debug>, C<env>, into effect. It also accepts style names previously defined with add_style(). =head2 add_style () This subroutine accepts a new style name and three style arguments as above, and creates, registers, and selects the newly named style. It is an error to re-add a style; call set_style_standard() to switch between several styles. =head2 add_callback () If your newly minted styles refer to any new #variables, you'll need to define a callback subroutine that will populate (or modify) those variables. They are then available for use in the style you've chosen. The callbacks are called for each opcode visited by Concise, in the same order as they are added. Each subroutine is passed five parameters. 1. A hashref, containing the variable names and values which are populated into the report-line for the op 2. the op, as a B<B::OP> object 3. a reference to the format string 4. the formatting (indent) level 5. the selected stylename To define your own variables, simply add them to the hash, or change existing values if you need to. The level and format are passed in as references to scalars, but it is unlikely that they will need to be changed or even used. =head2 Running B::Concise::compile() B<compile> accepts options as described above in L</OPTIONS>, and arguments, which are either coderefs, or subroutine names. It constructs and returns a $treewalker coderef, which when invoked, traverses, or walks, and renders the optrees of the given arguments to STDOUT. You can reuse this, and can change the rendering style used each time; thereafter the coderef renders in the new style. B<walk_output> lets you change the print destination from STDOUT to another open filehandle, or into a string passed as a ref (unless you've built perl with -Uuseperlio). my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1 walk_output(\my $buf); $walker->(); # 1 renders -terse set_style_standard('concise'); # 2 $walker->(); # 2 renders -concise $walker->(@new); # 3 renders whatever print "3 different renderings: terse, concise, and @new: $buf\n"; When $walker is called, it traverses the subroutines supplied when it was created, and renders them using the current style. You can change the style afterwards in several different ways: 1. call C<compile>, altering style or mode/order 2. call C<set_style_standard> 3. call $walker, passing @new options Passing new options to the $walker is the easiest way to change amongst any pre-defined styles (the ones you add are automatically recognized as options), and is the only way to alter rendering order without calling compile again. Note however that rendering state is still shared amongst multiple $walker objects, so they must still be used in a coordinated manner. =head2 B::Concise::reset_sequence() This function (not exported) lets you reset the sequence numbers (note that they're numbered arbitrarily, their goal being to be human readable). Its purpose is mostly to support testing, i.e. to compare the concise output from two identical anonymous subroutines (but different instances). Without the reset, B::Concise, seeing that they're separate optrees, generates different sequence numbers in the output. =head2 Errors Errors in rendering (non-existent function-name, non-existent coderef) are written to the STDOUT, or wherever you've set it via walk_output(). Errors using the various *style* calls, and bad args to walk_output(), result in die(). Use an eval if you wish to catch these errors and continue processing. =head1 AUTHOR Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>. =cut B.so 0000755 00000267500 15125366417 0005317 0 ustar 00 ELF > �Z @ @h @ 8 @ pG pG P P P � � � � � �? �? p3 p3 p3 �, �, �Z �Z �Z � � � � � � � � $ $ S�td � � � P�td � � � � � Q�td R�td p3 p3 p3 �, �, GNU � GNU s<� ���\��q�þ(� ` ` [ �� � � � ` � c C � � D � = � � j � > x � N u � � 4 � S � , � U � � � � � O A � � � q � � � q ) ^ | � � q � � � � � ( � � � � & � ) d g � � � � , � � � � t � 6 F " U � � } �� __gmon_start__ _ITM_deregisterTMCloneTable _ITM_registerTMCloneTable __cxa_finalize Perl_sv_newmortal Perl_newSVrv Perl_sv_setiv Perl_op_class PL_opargs Perl_stack_grow Perl_call_method Perl_gv_stashpv Perl_sv_bless Perl_markstack_grow Perl_sv_backoff Perl_croak_xs_usage Perl_croak_nocontext Perl_hv_common_key_len Perl_newCONSTSUB Perl_sv_upgrade Perl_gv_fetchpvn_flags Perl_sv_setiv_mg Perl_sv_setuv_mg Perl_sv_2iv_flags Perl_sv_2pv_flags Perl_mg_get Perl_sv_2bool_flags PL_op_name strcmp Perl_sv_setpvf PL_hash_state Perl_newSVpvf Perl_sv_2mortal Perl_sv_2pvbyte_flags __stack_chk_fail Perl_newSVpvn_flags Perl_sv_catpvn_flags Perl_sv_catpvf Perl_sv_uni_display memchr Perl_newSV PL_WARN_ALL PL_WARN_NONE Perl_newSViv Perl_newSVuv Perl_sv_setuv Perl_newSVhek Perl_gv_fetchfile Perl_get_sv Perl_hv_common Perl_newSVpv Perl_newSVpvn Perl_sv_magicext Perl_cop_fetch_label strlen Perl_emulate_cop_io Perl_op_parent Perl_sv_free2 Perl_sv_setpvn PL_op_desc Perl_custom_op_get_field Perl_multideref_stringify Perl_multiconcat_stringify Perl_av_fetch Perl_utf8_length Perl_newRV Perl_newSVnv Perl_sv_2nv_flags Perl_sv_setnv_mg Perl_mg_find Perl_croak Perl_cvgv_from_hek Perl_PerlIO_stderr Perl_PerlIO_stdout Perl_PerlIO_stdin Perl_mg_size Perl_cv_const_sv Perl_hv_fill Perl_hv_riter_p Perl_hv_placeholders_get Perl_hv_iterinit Perl_hv_iternext_flags Perl_refcounted_he_chain_2hv Perl_newRV_noinc Perl_mg_set boot_B Perl_xs_handshake Perl_newXS_deffile Perl_get_hv Perl_get_av Perl_av_push Perl_mro_method_changed_in Perl_my_cxt_init Perl_newXS Perl_sv_setsv_flags Perl_xs_boot_epilog libperl.so.5.32 libc.so.6 GLIBC_2.4 GLIBC_2.2.5 = ii G ui Q p3 �[ x3 �[ �3 �3 �3 �� �3 �3 �3 4 , 4 > 04 J H4 V `4 ` x4 k �4 t �4 } �4 � �4 � �4 � 5 � 5 � 85 � P5 � h5 � �5 � �5 � �5 �5 �5 �5 & 6 6 (6 ? @6 L X6 X p6 f �6 q �6 } �6 � �6 � �6 � 7 � 7 � 07 � H7 � `7 � x7 � �7 � �7 � �7 � �7 � �7 8 8 ( 88 2 P8 < h8 H �8 V �8 c �8 � �8 r �8 �8 � 9 � (9 � @9 � X9 � p9 � �9 � �9 � �9 � �9 �9 : * : 5 0: ? H: J `: Z x: d �: o �: x �: � �: � �: � ; � ; � 8; � P; � h; � �; � �; � �; � �; �; �; " < 2 (< B @< R X< [ p< i �< y �< � �< � �< � �< � = � = � 0= � H= � `= � x= � �= � �= � �= �= �= > % > . 8> > P> I h> ^ �> h �> x �> � �> � �> � �> � ? � (? � @? � X? � p? � �? � �? � �? � �? �? @ @ " 0@ * H@ 2 `@ ; x@ K �@ S �@ Z �@ l �@ z �@ � A � A � 8A � PA � hA � �A � �A � �A � �A � �A � �A � B (B @B 5 XB D pB U �B g �B u �B � �B � �B � C � C � 0C � HC � `C xC �C ' �C � �C � �C A �C ^ D t D � 8D PD @ hD � �D � �D � �D � �D � �D �D # E 6 (E H @E Z XE k pE w �E � �E � �E � �E � �E � F � F � 0F � HF `F xF ' �F 6 �F I �F X �F e �F y G � G � 8G � PG � hG � �G � �G � �G �G �G ' �G 7 H E (H S @H c XH s pH � �H � �H � �H � �H � �H � I � I � 0I HI `I # xI 2 �I K �I ^ �I n �I { �I � J � J � 8J � PJ � hJ � �J � �J � �J �J �J ( �J 8 K H (K ] @K j XK pK � �K � �K � �K � �K � �K � L � L � 0L HL " `L 6 xL B �L K �L W �L c �L q �L M � M � 8M � PM � hM � �M � �M � �M �M �M . �M < N R (N b @N o XN | pN � �N � �N � �N � �N � �N � O � O 0O HO `O , xO 8 �O I �O W �O h �O x �O � P � P � 8P � PP � hP � �P � �P �P �P + �P � �P � Q � (Q � @Q � XQ � pQ � �Q �Q �Q / �Q 9 �Q H R W R g 0R v HR � `R � xR � �R � �R � �R � �R � �R S S ' 8S 5 PS F hS R �S a �S o �S y �S � �S � �S � T � (T � @T � XT � pT � �T � �T � �T � �T � �T � U � U 0U HU `U xU & �U 0 �U = �U H �U R �U [ V f @V � PV � `V d� pV �� �V � �V Y� �V 2� �V � �V � �V G� �V 7� �V '� W �� W �� W �� 0W � @W �� PW O� `W �� pW {� �W � �W l� �W _� �W �� �W �� �W �� �W .� �W D� X �� X � X p� 0X � @X I� PX � `X � pX *� �X � �X N� �X N� �X �� �X � �X _� �X �� �X ?� Y �� Y �� Y �� 0Y :� @Y � PY V� `Y �� pY �� �Y � �Y Y� �Y j� �Y � �Y }� �Y � �Y p �Y v �Y ~ Z � Z � Z � Z � Z � (Z � 0Z � 8Z � @Z � HZ � `Z � hZ � pZ � xZ � �Z � �Z � �Z �Z �Z �Z �Z % �Z - �Z 3 �Z 9 �Z ? �Z E �_ �_ �_ % �_ . �_ = �_ A �_ E �_ O �_ R �_ [ �\ �\ �\ ] ] ] ] ] (] 0] 8] @] H] P] X] `] h] p] x] �] �] �] �] �] �] �] �] �] �] �] �] ! �] " �] # �] $ �] & ^ ' ^ ( ^ ) ^ * ^ + (^ , 0^ - 8^ / @^ 0 H^ 1 P^ 2 X^ 3 `^ 4 h^ 5 p^ 6 x^ 7 �^ 8 �^ 9 �^ : �^ ; �^ < �^ > �^ ? �^ @ �^ B �^ C �^ D �^ F �^ G �^ H �^ I �^ J _ K _ L _ M _ N _ P (_ Q 0_ S 8_ T @_ U H_ V P_ W X_ X `_ Y h_ Z p_ [ x_ \ �_ ] �_ ^ �_ _ � �H��H�� H��t��H��� �5� �%� � �h ������ �h ������� �h ������ �h ������ �h ������ �h ������ �h ������ �h ��q����� �h ��a����� �h ��Q����� �h ��A����� �h ��1����� �h ��!����� �h ������� �h ������� �h ����� �h ������ �h ������� �h ������ �h ������ �h ������ �h ������ �h ������ �h ��q����� �h ��a����� �h ��Q����� �h ��A����� �h ��1����� �h ��!����� �h ������� �h ������� �h ����� �h ������ �h! ������� �h" ������ �h# ������ �h$ ������ �h% ������ �h& ������ �h' ��q����� �h( ��a����� �h) ��Q����� �h* ��A����� �h+ ��1����� �h, ��!����� �h- ������� �h. ������� �h/ ����� �h0 ������ �h1 ������� �h2 ������ �h3 ������ �h4 ������ �h5 ������ �h6 ������ �h7 ��q����� �h8 ��a����� �h9 ��Q����� �h: ��A����� �h; ��1����� �h< ��!����� �h= ������� �h> ������� �h? ����� �h@ ������ �hA ������� �hB ������ �hC ������ �hD ������ �hE ������ �hF ������ �hG ��q����� �hH ��a����� �hI ��Q����� �hJ ��A����� �hK ��1����� �hL ��!����� �hM ������� �hN ������� �hO ����� �hP ������ �hQ ������� �hR ������ �hS ������ �hT ������ �hU ������ ��%M D � ��%E D � ��%= D � ��%5 D � ��%- D � ��%% D � ��% D � ��% D � ��% D � ��% D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%} D � ��%u D � ��%m D � ��%e D � ��%] D � ��%U D � ��%M D � ��%E D � ��%= D � ��%5 D � ��%- D � ��%% D � ��% D � ��% D � ��% D � ��% D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%} D � ��%u D � ��%m D � ��%e D � ��%] D � ��%U D � ��%M D � ��%E D � ��%= D � ��%5 D � ��%- D � ��%% D � ��% D � ��% D � ��% D � ��% D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D � ��%� D H�%( M���7E f. � @ H�=� H�� H9�tH�n H��t �� � � � H�=� H�5� H)�H��H��?H��H�H�tH�m H��t��f D � � � ��=y u+UH�=J H��t H�=�� ����d����Q ]� � � � ��w��� � AUATE1�UH��SH��H������Hc I��H��` H�� J9 �tJI��I��u��S H�E� I��H��L��H�����L��H��H���%���H��L��[]A\A]� � H��� �� � AWAVAUATI��USH��H���� H��H��L�-Y� �C!��� ��C!H�E L)�H���w H��M�|$���H��H��I�����L��H��I�T� � ���H��H��H���|���M�t$�C f%�f�� �� f=� tH�� %� ��% = �� M��= u0H�sHL��H���'���H�s@H��H������H�s8H��H��� ���I��H�H���!���H��L��[]A\A]A^A_� � �C"M���@tτ�y�H�C(�@!@�S���H�@L��H��H�@(H�@(H�0���H�I��H�������� � H�sPL��H�����H�I��H��������s��� D H�s0L��H���Y���H�I��H���q����K��� D L��L�� H�����I���n��� D AWAVI��AUI��ATI��USH��H��H��L��M�>����H� q� Hc� ��L� �I��` H� H�,�H������ I#D$H9�u+M�T$M��t!H������ I#BH� H9��0 L��L� $����H�$L��H��I����I��H��L��L���a����E@��tXI�FxH��I�FxI;�� �� L��I+VH���I�F L)�H���� I�oM�g� L��I�.H�5$� I�����I�FxH��I�FxI;�� �a L��I+VH���I�F L)�H���$ M�OM�g� L��M�L���Q���H��t5�C"�� H��L�������u�C f%�f=� t H�[HH���q���H��L��[]A\A]A^A_� D A�R ��%� �_�� A�B �� ��A�R � � �����I�H�x �����H�8 L�$�����L� L�����L��L��H�����L�$����f D H�k(H���9���L��L��H��L�����I��E!@����H�mH��u�� ��� � L��L��� L������I����� D L�������� L��L��� L�����I���9��� D L������ ��� L��L�\$L�$�w���L�$L�\$A�B ��A�R � � ���������� �ATUSH��H��H�CxH�P�H�SxH�SHc H� hH�H)�H����u.H�Hc�H��H��Hc@(L�$*H�4�,���I�$HkH�+[]A\�H�5�� ��� �AUATUSH��H��H�GxH�/H�P�H�WxHcH�GH��H��H)�H����upH�� H��t[H� H��L�hH���H�� H��M��I��H�� HD�L��H�����L��H��H������L�e H�+H��[]A\A]� D H��� �H��H�5ȍ �8��� � � �USH��H��H�GxH�/H�P�H�WxHcH�GH�H� �H��R(H)�H����u8H��8 ��H��P H��h HE�H��H�����H�E H�+H��[]�H��H�5>� ��ff. � � �AUATUSH��H��H�GxH�/H�P�H�WxH��J(HcH�GH��H��H)�H����u`��L��( LD� H���G���H��L��I�����H�b� L��H�߉�H���Q���L��H��H������L�e H�+H��[]A\A]�H��H�5�� ���f�� �H��H��H�PxH�pH�J�H�HxHcL��JE�H(L��H�L)�H����u2E��uHc�ƀ H�T�H�� � Hc�ƀ+ H�T�H��PH�5� �x� � � �H��H��H�HxH�H�q�H�pxH�@Hc H� �H��H)�H����u�PH�5�� �0�� �USH��H��H��H�CxH�+H�KH�P�H�SxHc H�4��PH��H)�H����u'Hc�H��@ t&H�pH�����H�E H�+H��[]�H�5�� ��H�=(� 1��� AWE1�I��AVI��AUM��A� ATUH��SH��j �v�ZYH��tlH�XI�ċC ��u ��< t��t=��L�k�C A�M ��L��L��L��H�����H��L��[]A\A]A^A_� D � H��H����C �L��H�=�� 1����f�� �USH��H��H�GxH�/H�P�H�WxHcH�GH��H��H)�H����u=A� � � H��H�5:� �[�H��H�@H�0���H�E H�+H��[]�H��H�5� ��ff. � @ � �AUATUSH��H��H�GxH�P�H�WxH�WHc H� hH�H)�H������ H�G�@#taH�HH�GL�$�A�D$ Hc�L�� H��L�l*�������uH��� t?��M�D$A�D$ M�eHkH�+H��[]A\A]� @ ���H�SI���f. � L��L��H�����H��H�5!� ��� �AVAUATUSH��H��H�CxH�KH�P�H�SxHc H�4��PH�H)�H������ Hc�L�4�L�$� H�C�@#tHH�PH�CH�,ЋE N�l!�������u?��� t6��L�u�E I�mLcL�#[]A\A]A^�H�����H�KH��� � L��H��H�������H�5�� ��ff. � �� �AUATUSH��H��H�GxH�P�H�WxH�WHc H��hD�i(H� �H�H)�H������ H�G�@#trH�HH�GL�$�E��uQD�ChA�D$ Hc�H��L�l*�������uO��� tF��M�D$A�D$ M�eHkH�+H��[]A\A]� D��� �f D ���H�SI���f�L��L��H���"��H��H�5Q� ���� �AUATUSH��H��H��H�CxH�KH�P�H�SxHc H�4��PH�H)�H������ Hc�H�4�L�$� �F % = uiH�L�h H�C�@#trH�PH�CH�,�H�CIc�N�l ��E ��������uX��� tO��H�U�E I�mLcL�#H��[]A\A]� � � H�����I��H�C�@#u�H�����H��덐H��H������H�5H� �� � � �ATSH��H��H��H�CxH�H�sH�H�H�KxHc L�ƍHH��L)�H����ucHc�L�b�H��@ tDH�p�F % = u H�H�p L��H�����H�H��[A\�f�� H����H����H�=�� 1����H�5� �� @ � �AVAUATUSH�GxH��H�P�H�WxH�WHc H�D�h�i(H� �H�H)�H������ H�G�@#�� H�HH�GL�$�Ic�L�,� H��@ �� H�p�F % = u_H�H�@ ��uL�hA�D$ N�t*���������uh��� t_��I�T$A�D$ M�fLkL�+[]A\A]A^�f D #h � � H�����H�S� D ��H�SI���L��� � L��H���-��H��H�5�� ���H�=S� 1���ff. � � �AUATUSH��H��H�GxH�P�H�WxH�WHc H� �D�`H�H)�H����� H�G�@#�� H�HH�GH�,�Ic�L�$� H��@ �� H�p�F % = ucH�H�p �V �� �� ucH�H�P H�C�M N�l ���%�����ut��� tk��H�U�M I�mLcL�#H��[]A\A]� � H����H���f D � H����H���f D ��H�SH���0��� � H��H�����H�=�� 1��E�H��H�5G� �V�f D � �USH��H��H��H�CxH�+H�KH�P�H�SxHc H�4��PH��H)�H����uiHc�H��@ tNH�p�F % = u,H�H�@ �@ tHH�pH����H�E H�+H��[]� D � H������H�=@� 1���H�5�� ��H�=<� 1��q��� �AWAVAUATUSH��H��H��H�CxL�#H�KH�P�H�SxHc H�4��PL��H)�H������ Hc�I��H��@ �� H�p�F % = �� H�H�@ H� L�5Ł M��L�xM��u �M D M��H�C L)�H��~QH��M�l$���L��H��H��H����L��H��H���m�I�l$M�?M��u�L�+H��[]A\A]A^A_�f D L��L�� H����I��뗺 H���S��Y���H�=�� 1��@�H�5E� �T� @ � �AUATUSH��H��H�GxH�P�H�WxH�WHc H� �D�`H�H)�H������ H�G�@#�� H�HH�GH�,�Ic�L�$� H��@ �� H�p�F % = t� H����H�S�E N�l"�������uM��� tD��H�E �E I�mLcL�#H��[]A\A]� � �k�H�SH���h��� � 1�H��H�����H��H�5+� �:�H�=� 1�� �ff. � �� ����� � � �ATUSH�GxH��H�P�H�WxH�WHc H��hD�a(H� �H�H)�H������ Hc�H��H�H��@ �� H�p�F % = u_H�H�@ E��u#H�x u/H��8 H�HkH�+[]A\�f D �@ ���� � �� � t5H��h H�HkH�+[]A\� � � � �H�SH�� D ���� ��w��H��H�5� ��H�=�~ 1����f D � �AUATUSH��H��H�GxH�P�H�WxH�WHc H� �D�`H�H)�H������ H�G�@#�� H�HH�GH�,�Ic�L�$� H��@ �� H�p�F % = uKH�H�@ L�@�E N�l"�������u[��� tR��L�E�E I�mLcL�#H��[]A\A]�f�� H����H�S� D ��H�SH���`��� � L��H��H�����H��H�5�� ���H�=�} 1��� � �AUATUSH��H��H�GxH�OH�P�H�WxHc H��D�`H�H)�H������ H�G�@#�� H�PH�GH�,�Ic�L�$� H���@ �� H�p�F % = u[H�H�@ H�@N�l!��P@�E �����������ub��� tY��H�U�E I�mLcL�#H��[]A\A]�f � � H�����H�K� D ���H�KH���P��� � H��H�����H��H�5x� ��H�=`| 1��v�f D � �AUATUSH��H��H�GxH�OH�P�H�WxHc H��D�`H�H)�H������ H�G�@#�� H�PH�GH�,�Ic�L�$� H���@ �� H�p�F % = u[H�H�@ H�@N�l!��PC�E ���������҃�ua��� tX��H�U�E I�mLcL�#H��[]A\A]� � � H����H�K� D ��H�KH���P��� � H��H������H��H�58� �d�H�= { 1��6�f D � �AUATUSH��H��H�GxH�P�H�WxH�WHc H� �D�`H�H)�H������ H�G�@#�� H�HH�GH�,�Ic�L�$� H��@ �� H�p�F % = t� H�����H�S�E N�l"�������uM��� tD��H�E �E I�mLcL�#H��[]A\A]� � �k�H�SH���h��� � 1�H��H���[��H��H�5z �:�H�=z 1�� �ff. � �� �AUATUSH��H��H�GxH�OH�P�H�WxHc H��D�`H�H)�H������ H�G�@#�� H�PH�GH�,�Ic�L�$� H���@ �� H�p�F % = uSH�H�@ H� N�l!��P\�E ����������u^��� tU��H�U�E I�mLcL�#H��[]A\A]� D � H�����H�K� D �+�H�KH���X��� � H��H���]��H��H�5iz ���H�=�x 1����ff. � � �AVAUATUSH��H��H�CxL�#H�KH�P�H�SxHc H�6�P�n(H�4�L��H)�H������ Hc�H��@ �� H�p�F % = u|H�H�@ H� �@\u���| L�h0M��� E1�E1�H���B�L��H��H�����H�]� H��H�߉�H���L�L��H��H����I�,$L�#[]A\A]A^�f D � H�������y���f D L�h(M���H�=�w 1����H�5*y ���ff. � f�� �AUATUSH��H��H�GxH�P�H�WxH�WHc H� �D�`H�H)�H������ H�G�@#�� H�HH�GH�,�Ic�L�$� H��@ �� H�p�F % = uSH�H�@ H� N�l"�Lc@`�E ������u`��� tW��L�E�E I�mLcL�#H��[]A\A]� � � H�����H�S� D ��H�SH���X��� � L��H��H������H��H�5�w ���H�=|v 1��[��ff. � � �AVAUATUSH�GxH��H�P�H�WxH�WHc H� hH�H)�H������ Hc�H��L�,� �@ �� H�p�F % = �� H�H�@ H� �@\tLH��E1�����H�Hu I��L��H�����L��H��H���v��H�CL�$�LkL�+[]A\A]A^�f D L�pHH�����H��t I��M��H��t HE��f�� �V���t���H�=du 1��C��H��H�5�v �T�� @ � �AUATUSH��H��H�GxH�P�H�WxH�WHc H� �D�`H�H)�H������ H�G�@#�� H�HH�GH�,�Ic�L�$� H��@ �� H�p�F % = uSH�H�@ H�H�E N�l"���D�������u`��� tW��L�E�E I�mLcL�#H��[]A\A]� � � H���K��H�S� D �[��H�SH���X��� � L��H��H������H��H�5>t �)��H�=5t 1����ff. � � �AUATUSH��H��H�GxH�P�H�WxH�WHc H� �D�`H�H)�H������ H�G�@#�� H�HH�GH�,�Ic�L�$� H��@ �� H�p�F % = uKH�H�@ L� �E N�l"�������u\��� tS��L�E�E I�mLcL�#H��[]A\A]� � H�����H�S� D �#��H�SH���`��� � L��H��H������H��H�5Qu ����H�=s 1����� � �AVAUATUSH�GxH��H�P�H�WxH�WHc H� hH�H)�H������ Hc�H��L�,� �@ �� H�p�F % = uhH�H�@ H�@H��L�0�b��H��r H��M��I��H��q HD�L���o��L��H��H������H�CL�$�LkL�+[]A\A]A^�f � � �����H�=&r 1�����H��H�5Gt ���� � � �AVAUI��ATUSH�GxL�'H�P�H�WxH�WHcH�4�H��D�qL��H)�H������ ��H��I��H�H�4F % = �� H�H�X Mc�J��@ �p H�p�F % = �� H�L�p H��xI9 }:H�E L)�H���� H��1�M�l$�;��I�D$L�m []A\A]A^�f � H��tsH�E L)�H���� I�FH��M�l$H�4����I�D$L�m []A\A]A^� @ � ���H�UH���7���f. � � H���s��I���G��� H�E H�P�H�ExH�U H��H�ExH;�� tgH��H+UL��H��H���[]A\A]A^�f���f D L��L�� H���M��I����� D L��L�� H���-��I������ D H������H�U �H�=p 1�����H�50p L������ D � �AUATUSH��H��H�GxH�P�H�WxH�WHc H� �D�`H�H)�H������ H�G�@#�� H�HH�GH�,�Ic�L�$� H��@ �� H�p�F % = t� H��� ��H�S�E N�l"�������uM��� tD��H�E �E I�mLcL�#H��[]A\A]� � ����H�SH���h��� � � H��H������H��H�5q ���H�=�n 1����f � � �AWAVAUATUSH��H��H��H�CxL� H�KH�P�H�SxHc H�4��PL��H)�H����� Hc�M�i�H��@ �� H�p�F % = �� H�H�@ H�$H�$H�8 x}H�$M��1�H�@H�D$� M��H�����H�>m H��I��H�D$L��L�$�H�5n M��HE����L��H��H���k��H�C L)�H��~OH�$M�~M�nH��H9(}�L�+H��[]A\A]A^A_� � � H���S��H�$�I���f. � � L��L��H���m��I���H�=�m 1����H�5�m �.��ff. � � �AVAUATUSH�GxH��L�GH�P�H�WxHcI� �H�ЍjH�H)�H����� ��H�I�4��F % = �� H�L�` Hc�I��L�,� �@ �� H�p�F % = �� H�H�@ M��xL9 }MH��E1��r��H��k I��L��H�����L��H��H�����H�CL�$�LkL�+[]A\A]A^� � H�@H��N�4�� ��H�ik I��M��H�ll HE��f D � ����L�CI���,���f. � � H������G���H��H�5Jl ���H�='l 1������ �AUATUSH��H��H�GxH�OH�P�H�WxHc H��D�`H�H)�H������ H�G�@#�� H�PH�GH�,�Ic�L�$� H���@ �� H�p�F % = u[H�H�@ �P)N�l!��Љց� ��E E։������҃�uZ��� tQ��H�U�E I�mLcL�#H��[]A\A]Ð� H�����H�K� D ���H�KH���P��� � H��H�������H��H�5k ���H�=k 1��V��f D � �ATUSH��H��H�CxH�KH�P�H�SxHcH�4�H�ЍjH�H)�H������ ��H�H�4��F % = uZL�fHc�H�,� H���@ tH�p�F % = uNH�H�p H��P L��H���e��H�CH�D(�H�[]A\� @ � 1�H���!��H�KI��� � � H���s��H���H�5/j ���H�=.j 1��T�� @ � �AWAVAUATUSH��H��H�GxL�'H�P�H�WxH�WHc I�ƍhH��I)�H�GI���@#�� H�HH�GL�,�Hc c� H��` H� �D�y@E��_A�E Hc�H����L�d*�Icׁ������� ��� �� ��I�UA�E M�l$HkH�+H��[]A\A]A^A_� � A�FH�L�$�M��t�A�D$ �� H��8 L��H)�H��Hw2I9�ue�A@ H�S�^��� D �S��H�SI���-��� � A�D$ ��t.��tQI�$H��t H�@H��w�H��tI�D$�80u� � H�S� ��� � L��H������%��� � ��t;I�$H�x �_�����f. � L��H��H�L$� ��H�L$�!���f D ��u+1�L��H��H�L$�y��H�L$�������o��� � I�D$�@��H� H� �@����ff. � @ � �AWAVAUI��ATUSH��H�GxH�oH�P�H�WxHc H�T� D�xH�H)�H������ Ic�L�4� H�D$L�H�u �F % = �� H�^L������H�E �;pt]L�%�� E1���I��I��� t{K�4�H���g����u�Ic�I�EH�L$L��H�4��+��MuM�u H��[]A\A]A^A_� @ �{pu�H�C�{_HD�� @ � 1����I�mH��L��_��� D H������H��H�5�g ���� �AVAUATUSH�GxH��H�oH�P�H�WxHc H�T� D�hH�H)�H������ Mc�N�$� L�H�u �F % = u1H�Lcp H�����H�E A��� v5LcL�#[]A\A]A^� D � �V��H�kLc�L��f. � H�Y� H��H� f J� �H�CJ�4�1����LcL�#[]A\A]A^�H��H�5�e � ��ff. � f�� �AWAVAUATUSH��H��H��(H�KdH�%( H�D$H�CxH�P�H�SxHc H�4��PH�H)�H������ Hc�H�4�H�,� �F % = �� H�L�@H�FL�D$I���� H�5J� H�=�� Jc ��W H�>��f D �H3��$\ �H3��$X �H3��$T �H3��$P �H3��$L �H3��$H �H3��$D �H3��$@ �H3��$< �H3��$8 �H 3��$4 �H 3��$0 �H 3��$, �H 3��$( �H 3��$$ �H3��$ �H3��$ �H3��$ �H3��$ �H3��$ �H3��$ �H3��$ �H3��$ � 3T�$��H�5(d H��1����L�cH��H���z��I�I�$HkH�+H�D$dH+%( �$ H��([]A\A]A^A_�f � H�T$� H�����L�D$�Y��� @ H�OQU���I�xL� �� H�N�z#���H��H�'Q�`so�I��I39H�I3QI�� �; H�9{�픽)�A��)�H��qkɾ8}�I��ȠXz8npI��A����A��'ˑA��i��H�I3IH�?2(� ��I��L�I3qM�H�I��I��M�YL�L$I��I��I� � I�2I�� I��H�H��H��I�r�L1�I��H�I�r�H��I��H1�H�I�r�H��I��H�L�H�� H)�I��M9�u�M��L�T$M�H�A�� I��I��I���b I���? I���g M)�A��H�� H�?2(� ��L��H)�I1�H�=�� Jc�H�>�� D H�0A��D�HH�?2(� ��H��H�H��H1�H�� H�4H�PH��H�HH�H�=q� H��H1�H�� H�H�Jc �H��H1�H�H�� H�>���H H�� H��H H��0H��H H��Hʋ@H�H1�H�� H�H��H1�H��H�H�� H)�H�� H1�H)�H��H�H��H1�H��H�H��H�H��H1�H��H1������HH��0H��@H��A�CH�A�CH�A�H�I��L)�H)�H��H�� H1�H��I��I��L��L)�H)�L�H��H��H��H�I)�H�� I��H1�I��H)�I�� L��H)�H)�L�I�H��H��H��H��L1�H1�H�H�� H1�H��H��H1�H��H��H)�H��H1�H��H1�H1��I���A�CH�A�H��G���A�CH�A�H��3���A�H�H�� @���� ���f. � M�#N�\(L�H��H��H1�H�Ǹ���I�I��H�H��H1�H�¸�'ˑI�I��H�H��H� 8�|���H��L�H�� 4��3���H�5�d ��������ff. � @ � �AWAVI��H��AUATUSH��(M�&I�NdH�%( H�D$1�I�FxH�P�I�VxHc H�6�P�n(H�4�L��H)�H����� Hc�L�<ѹ � ���( A�G � �� H�5P_ L���[��H��A�G ��t � � % = �e I�M�H�@H�D$L�-�� H���� D A���"�� ��\�� ����H������t ��?�Y ������$u���� ��@u��� D��A�@�^�� �B�<�F ��IcD� L�>�� � H�5�_ L�����H��I� $M�&H�D$dH+%( �� H��([]A\A]A^A_� @ L�-^ L��L���>��H��A�G % = � I�W� ��'�W ��\�n D��A�@�^� �����X ��H�g� A� Hc�� H�>��f�L��H�T$� L�����I��H�D$���f D 1ҹ L��L�����H���k���f D A� � H��L��H�D] ��� H�D$I��H��H�D$H���=���A� � H��L��H�"] �P������ A� � H��L��H��\ �+����f � A� � H��L��H��\ �����v���f D A� � H��L��H��\ �����N���f D A� � H��L��H�u\ ����&���f D A� � H��L��H�J\ ������f D �� u���� D��H�/\ H��L��1�� ������� � L��H�-\ L�-\ � ��L��A� L��H��I�H�HH�����I��� ��ua��� @ A�w� H�����H���� I�GA� L��H� L��H�D$�˿��H�D$f D L�x�@���C���<"� <$�8 <@�X <\t�A� L��H��L��� �{���L���f D A� � H��L��H�$[ �S�������f D A� L��H��L��� �/������f. � A� � H��L��H��Z �����v���f D A� � H��L��H��Z �۾���N���f D A� � H��L��H��Z 賾���&���f D A�?������? �#��� A� � H��L��H�DZ �s���L����� A� L��H��L��� �O���L����� � A� � H��L��H��Y �#���L���[��� A� � H��L������A� L��H��L��� ����F��� @ A� � H��L��H�sY �ý��뿐A� � H��L��H�VY 製���H�ZY H��L��菽���H�IY H��L���{����t���H� Y H��L���d����]���H�Y H��L���M����F���H��X H��L���6����/���H��X H��L��� �������H��X H��L���������� A� � H��L��H��X ���L������A� � H��L��H��X 込���1���D��H�uX H��L��1��b������H�5R] �a����<���ff. � �� �AVAUATUSH��H��H�CxL�+H�KH�P�H�SxHc H�6�PD�v(H�4�L��H)�H������ Hc�H��@ �� H�p�F % = �� H�L�` A���� A���� H�C�@#�V H�PH�CH�,ЋM ��� �ʃ���������!�E���� A�|$ I�$� ��� f���� ��� ��H�U�M I�m L�+[]A\A]A^ÐA�|$ I�$�� H��� H���A���H��I�m L�+[]A\A]A^�f D � H���ۺ��I��A��� ���I�$A�|$ H�PuH�@��� H��H�߹ ��H)�It$�Ǽ��H��I�m L�+[]A\A]A^� @ ��t\��L�e�M I�m L�+[]A\A]A^�f�H�@�G��� � H�R�� � H���X���H�����H��H��蕾���"���L��H��H���B�������H�5[ �!���H�=�T 1��� � �ATUSH��H��H�CxH�+H�KH�P�H�SxHc H�6�PD�f(H�4�H��H)�H������ Hc�H��@ �� H�p�F % = uGH�H�@ E��tH�@HcP���u>H�p� � H�pH��蔿��H�E H�+[]A\� � � H���3���뱐�L H�pH��� �� �� �@���H���H�=7T 1����H�5&T ������ �H�GxH�S�G H��H�H�H�OxHcH�GH� �H��H)�H��H�H��H)�H��n���H��` Hc � H�@H��H� H�H�Q@H� H�@0 H�P@H��P H�PH��8 H�PH��h H�À H�PH�t� H�X8H�P H�M� H�P([� � � �AUATUSH��H��H�GxH�P�H�WxH�WHc H��hD�i(H� �H�H)�H������ Hc�H��L�$� �@ �� H�p�F % = uoH�H�@ H� �P\E��t=��uh��t8H�p(H���G���H��H�����H�SH��LcL�#H��[]A\A]�f���u 1��� � H�p0�f. � � �F���� @ H�p(H���t����H��H�5�S �C���H�=6R 1����� D � �ATUSH�GxH��H�P�H�WxH�WHc H� hH�H)�H������ Hc�H��L�$� �@ toH�p�F % = uPH�H�@ H� 1��@\u.H���&���H��H�����H�SH��LcL�#[]A\� � H�pH��f. � � �V����H�=gQ 1��F���H��H�5�R �W��� � � �AVAUATUSH��H��H�CxL�#H�KH�P�H�SxHc H�6�P�n(H�4�L��H)�H������ Hc�M�l$�H��@ �� H�p�F % = u'H�L�p ������H�tw Hc�H�>��f D � H��苵��I����f D A�~r�b H��M�n 艺��H��I�$H��L���'���L�#[]A\A]A^� A�~r� I�v 1�H��t)H��~ H�HH�Q�H�N�� ��� ��H)�Hι H���,���I�$�f D H�C L)�H���� M�6H��P M��t+H�����H��O H��H��H������L��H��H���v���I�m�F��� D H��E�n諹��H��I�$H��L���y���� ��� @ H��M�n脹��H��I�$H��L���"������ D I�v H���|���I�$���� I�v(H���� I�VH��yjH��H����� �(���I�$��� � H��E�n� ���H��I�$H��L���ٵ���}��� @ I�v� � H�����I�$�Z����� H���ӵ��I�$�C���f. � H�@�n��� � H��蘸��I�$���� � 裹��I�$����L��L�� H��至��I��L�`�[���H�=fO 1��-���H�5UO �A���H�="r 1�����H�=�q 1����� D � �ATUSH��H��H�CxH�KH�P�H�SxHc H�6�PD�f(H�4�H�H)�H������ Hc�H�,� H���@ �� H�p�F % = uzH�H�@ E��u6H� H�p H�����L�cH��H���ȵ��I�I�$HkH�+[]A\� D A��tJ1��@t�H�H�@H�RH�D�H�0H��t��@ ��t�H�6�f D � H��� ����{���f D H�@H�pH�t���H�5�R ����H�=�L 1��ٴ��f � � �ATUSH�GxH��H�P�H�WxH�WHc H� hH�H)�H������ Hc�H��L�$� �@ tvH�p�F % = u8H�H��P H�@ H� �@]�u;H��豴��H�SH��LcL�#[]A\� D � �.���H��P H� �@]�t�H�p8H��蒱��H���H�= L 1����H��H�5}M ����� �USH��H��H��H�CxH�+H�KH�P�H�SxHc H�4��PH��H)�H����uyHc�H��@ t^H�p�F % = u<H�H�@ H�@H�pHH��tH��H���d���H��H��詶��H�E H�+H��[]� � H���K����H�=%K 1��;���H�5#Q �O���ff. � @ � �AWAVAUATUSH��H��8H�GxH�P�H�WxH�WHc H��hD�y(H� �H�H)�H������ Hc�H�� H�D$H��@ �� H�p�F % = �j H�L�p A��8�} Mc�L�%7� 1�H��L��H�5�K H��L��HH� �L$'H�D$�L���H���� �@ �� L�XA�{ L�\$�� L��H���ڳ��H��E1�E1�j 1�H��H��j j H�t$0H�D$H胲��L�T$HH�� M��tA�R���8 ��A�RH��tlH�@H��tc�@ t]H�p�~ uS�L$'H��H��E1�j H�T$(A� 貲��^_H��t+H�H��t#H�CH��H�D$HCH�H��8[]A\A]A^A_�I��M�A�D$ <toA�T$ I�<�z H�7p Hc�H�>�� D � �.���I�����f D A�6H��襱��H��H���j���I��H�CL�$�H�D$HC�o����A��8�� H��o D��Hc�H�>��f�M�.H�����L��I��H��藲��H� � ��H��L��H�����L��H��H���a���� � I�6�c���A�6�Z��� � I�6H������H��H��躰��I���K���f�I�61�H������H��H��蘰��I���)���I�6H���e���I������H�t$H�=|I 1�� ���f. � A�� � A�� A�v!A���� H��o Jc�H�>��A�T$���� ��A�T$1�H����I�����A�F f%�A�� �� f=�7 H��� %� H�4�1��+���I�V8H��@ H��L�,�A�} �� �t���I���E���A�F H�`� H�5�H H��%� H��1�����H��H���{���I��H� H�x ����� � ID$��ʃ�a���z�B׃��I�$Hc�H;Br�����A�F E1�E1�f%�f�� uM�~PM�� � H���Ȱ��L��I������A�F!@�q M�nM��H��裰��L��H��I���U���H��� L��H�߉�H��譯��L��H��H��� ����C���1�A�FB�����I�VPH��P H�4�H��������F�� H�H�PH�FH�D�H�0H��������x t H�6H���p���H��1����A�F f%�f=� �� M�nH���A�F 1�f%�f-� f�������I�v0���L��H���y���H�Bn ��H�4��j���I�V(H��P H��H��t �P �� �� H��P ����I�V(H��P H�4�H��脰��I���5���I�v0H��t�H������H����Hc �� I�F@A� H��` H��f. � J;��` I��s�H�H�pH�����H��I�����A�U H��I��H��� H��L������L��H��H��I���w���H��1�L��j E1�E1�L��H������A�UXY���� ��A�U�i���1��L���I�F(1�H���=���f. � H���@!@�%���H�@H��u�����1�L��1�H�����1�H������A�F M�f(f%�f��"�� L���ܩ��H��L�� H������I������A�F E1�E1�f%�f=� ����M�~(M��� ���H��@ I�V8H��H�4�1��~ HE��ۮ��I�����A�F 1�f%�f=� �2���I�v(�)���H��荭��M�nHH��D I�����1�H������L��H��I��H�����A�D$ � �^���L��H���e���I������L��赪��I���@���@��@�����@��������@�������@�������@�������@�������@�������f � L��H��H�D$� ���H�D$���H��讬��H��A I������蚬��I��I�E A��&�� A�} H�HuH�@��� H��L��H�߃�H)�IU�Z���A�E �(���A�L$ ����E1�E1����I�$H�T ����f=�� H�/� %� H�4�1����A�v �� ���H�����I�VHH��H��I��荫�����A�} uH�@�P8L��H��蟨�����1��� t!H�H�@H�RH�D�H�0H��t �x tH�6H�����H��� ���1�1�� ���� L��H������1�H����� L��H�����1�H������H�=�B 1�����D��H�=:e 1�����H��H�5B ����L��H���i����(���L��H���Y�������H�T$��H�= e 1�辨��ff. � � �AWAVAUATUSH��H��H�GxH�P�H�WxH�WHc H� �H��D�`H�H)�H������ Mc�J��N�,� �@ �� H�p�F % = �� H�L�p ��Hc�H��@ �u H�p�F % = �� H�H�P A�N M�~0f��f��� �� wFf��C� f��� �� L��H��覨��H�SJ��LkL�+H��[]A\A]A^A_� � f��� uaH��L��H�5A 1��u���H��H���ڧ��� � � �f���H�SI���'���f. � � H���C���H���:��� H��1�H�5�> �'���H��H���|����Q��� � I�OI�H�5�@ 1�H�����A�OH�ń�u,H��H���A������� @ L��H��荥������ � H��H�I@ H��1�輤���H�=�> 1�蜦��H��H�5@ 譥��H�=F@ 1�����ff. � @ � �AWI��AVAUATUSH��(H�GxL�'H�P�H�WxHcH�GH�ՍZH� �L��H)�H�����; Hc�I��H��L�,� �B �; H�r�V �� �� �R H�L�r ��Hc�H��@ �� H�p�F % = �@ H�H�@ A�V M�N0f��f��� �� �� f��C�P f��� � H� I�I�M�1H�@HH�L$H�@H�@H�D$H���� I�G L)�H��H9��� L��L��L� $I�l$���L��H��艥��L� $I�D$L�%ae f � L���H�� �� Ic�L�>��f D f��� �} I�G L)�H���} L��L���z���L��H��� ���I�D$I�_L�I� H��([]A\A]A^A_Ð� 薡��I��I�G���f. � � L���s������f D �$I�QH�t$I�A1�L��H�D$L�m��L��H�0�y���L�L$H�EL���0H�� �� �� H���A H���/ �<$ L���� I�QH�t$1�L��L� $蓤��L��H�0����H�EA��@�� L� $H��I��I����� D �$I�qI�AL��L�mH�D$�#���L��H�����L�L$H�EL���0H�� �O���I�qL��L� $���L��H��责��I�EA��@uz�S D �$ �f. � �$ ���� � L���0H�� �� �� H��t5H���� I�qL��L� $蛤��L��H���@���H�EA��@����f�I�GH\$H�\�� ��� D L���0H�� � wVH��t�H��������N D M�qL��M�iL��� ���L��H��H�EH�$�ʢ��M��H�EH�,$�J���f. � I��H��0t%A��@�m��� D I��� ��� � H��0uJI�QH�t$1�L��L� $転��L��H�0�@���I�EA��@�"���L� $I�mI��I������ D A��@�����I��L�����f�I�G L)�H���� I�1L��L� $�P���L��H�����L� $L��I�D$I�q�0���L��H���ա��L� $I��h I�D$A�Q���� L��I�\$諡��I�D$����M�1L��H��� I�G L)�H��H9��� L��L��L� $I�\$踢��L��H���]���L� $I�D$I�qI�QI�i(H���� L��L� $E1�I�n�̢��L��H���!���I���L� $I�D$�����f D K�t�(L��L� $�G���L��H�����L� $K�D�L��I��I9�u�H� ����f D I�GJ�\(����f. � I�qI�Q L���@���L���H H��I��苠��I�D$I�EH�$I����a���M��I��f D H�u H��~H�$L��H�0H��H�$訠��H��L��I��H��腡��L��H���*���I�$I��s�J�\�����f D H�5=9 L��1�菡��H���?��� � I������ � H�L$L��L��L��L� $詜��L� $I������ D L��L�� L��L� $聜��L� $I���`��� D L��L��L��L� $�^���L� $I�����f�L��L�� L��L� $�9���L� $I���>���H��H�5h8 ���H�=�6 1��О��H�=�8 1����f�� �ATUSH��H��H�CxH�KH�P�H�SxHc H�4��PH�H)�H����uyHc�H�,� H���@ tVH�p�F % = u1H�H�p H��肟��L�cH��H��裞��I�I�$HkH�+[]A\ú H���#���H����H�=�5 1�����H�5< �$��� @ � �AUATUSH��H��H�GxH�P�H�WxH�WHc H��hD�i(H� �H�H)�H�����q Hc�H��L�$� �@ �J H�p�F % = u7H�H�@ D��A��H0���� � H��] Hc�H�>��f D � �N����� @ H�6H���͝��H��H��蒝��H�SH��LcL�#H��[]A\A]� � H�6H��赞��H��H���Z����� � H�6H���%���� Hc6� �6� �6� @ �6�{���H�6H��1��s���H��H�������q��� �H����H��H������R��� @ � � H��螛���7���D��H�=�X 1��X���H�=�3 1��J���H��H�5L: �[���ff. � � �AUATUSH��H��L�gdH�%( H�D$H�GxH�P�H�WxHc H��hD�j(I��H�H)�H������ Hc�H��I�I�$�@ �� H�p�F % = uZH�H�@ H� H�@ E��tdHc�H��8 H��h H9�H��HD�I�$HkH�+H�D$dH+%( u[H��[]A\A]�f D � �N���L�cH� I�H�@ E��u�H��H�� H��H�� ȉD$ʉ$� �D���I�$�� ���H�=�2 1����H��H�5�8 � ���ff. � �� �AUATUSH��H��H�GxH�P�H�WxH�WHc H� �D�`H�H)�H����� H�G�@#�� H�HH�GH�,�Ic�L�$� H��@ �� H�p�F % = ukH�H�p �V �� �� ukH��@(H�CN�l ��E �����uz��� tq��"�E H�E �@(I�mLcL�#H��[]A\A]� @ � H�����H���f D � H��� ����f � �ۛ��H�SH���(��� � H��H��� ����H�=B1 1�荙��H��H�5�7 螘��ff. � � �AUATUSH��H��H��H�CxH�KH�P�H�SxHc H�6�PD�f(H�4�H�H)�H�����5 Hc�H�,� H���@ �( H�p�F % = �� H�H�x A���� �O A���� E��tEL�gL��詖��� H��L�kL��H�����I�I�E HkH�+H��[]A\A]�f � ��u#��t ��%�� = t� 1�E1�� @ H��� L�g�� H�P� � H�ߺ �;���H��A���G����B �d���H��tFL�`(H�P� �L��� D H�L�g� H�P�2���H�5�5 ����H�=�/ 1��ٗ��H�=zT �͗��ff. � f�� �AVI��AUATUSH�GxH�P�H�WxH�WHc H��XD�i(H� �H�H)�H������ Hc�H��L�$� �@ �� H�pH���F % = unH�H�@ H�@H���� A��H�D���� t5��uL�0H��覗��H��H���k���H�UH��LeL�e []A\A]A^�f�H�0H���%����� � �֓���D��H�=�S 1��Ö��H�5�4 L���ԕ��I��@]�u:H�@8H�70 H��t H� H�P H��H�5$0 H��1����H�=[. 1��q���L��H���F���� @ � �ATUSH��H��H�CxH�KH�P�H�SxHc H�4��PH�H)�H������ Hc�H�,� H���@ tvH�p�F % = u=H�H�p H��@]�uFH�p8L�cH��� ���I�I�$HkH�+[]A\�f. � � H��賒��H��H��@]�t�H������H���H�=�- 1�茕��H�5 / 蠔��� �AVAUATUSH��H��H�CxH�KH�P�H�SxHcH�4�H�ЍjH�H)�H�����3 ��H�H�4��F % = �� L�fHc�H��L�,� �@ � H�p�F % = �� H�L�p H�5�. L���ȓ������ H�5�. L��豓����tMH�5�. L��螓������ H���^���H��h I9Ft6H�CH��LkL�+[]A\A]A^�f � H��舑��H��h I9Fu�H��8 �f�� 1�H���ђ��H�KI������ D � H���#���I���4��� H���`����m���H�5�- � ���H�=�- 1���L��H�=�- 1����� �AUATUSH��H��H�GxH�P�H�WxH�WHc H� �D�`H�H)�H������ H�G�@#�� H�HH�GH�,�Ic�L�$� H��@ �� H�p�F % = u[H�H�p �F�udH�L�@H�C�U N�l ���%�����uo��� tf��L�E�U I�mLcL�#H��[]A\A]�f D � H����H��F�t�H���R���Lc�� D ��H�SH���@��� � L��H��H������H��H�5V9 ���H�=�, 1�蓒�� � �AWAVAUATUSH��H��H��H�CxH�+H�KH�P�H�SxHc H�4��PH��H)�H�����5 Hc�H��H��@ �, H�p�F % = �� H�L�` A�D$ � � �� I�$H�z xmM�t$E1��=I�$H�@I9�VH�C H)�H���� K�4�H��L�}A�����H�EA�D$ L��Mcũ � t�L��H��L�D$� ���L�D$H�I9�~�H�+H��[]A\A]A^A_� � H���k���I��A�D$ � � �S���L��H��轐����x�A�D$ �E��� � H��H�� H��L�D$�`���L�D$H���@���H�5�7 �'���H�=�* 1����f � � �AVAUATUSH��H��H�CxH�+H�P�H�SxH�SHcH�4�H��D�iH��H)�H������ ��H��H�H�4F % = �� H�Lc` Mc�J��@ �Z H�p�F % = �� H�L�h E��x/A�E��� I�E H�@H��xH�S L9��� f. � H�C H)�H���� H��1�L�u�B���H�EL�3[]A\A]A^�f�� H�����H�SLc��T��� � � H���Ì��I���g��� L��H��� �����x�A�E��� L��H������H�S H�L9��d���H)�H��~LI�EH��L�uJ�4�訒��H�EL�3[]A\A]A^� � H��H�� H���}���H���%��� D H��H�� H���]���H���H�=) 1�� ���H�5) � ���I�E H�@����� �USH��H��H��H�CxH�+H�KH�P�H�SxHc H�4��PH��H)�H����ulHc�H��@ tQH�p�F % = u,H�H�x �x���H��H��轑��H�E H�+H��[]� � H�ߺ �[���H����H�=i& 1��H���H�5�' �\���ff. � �� �AUATUSH��H��H�GxH�P�H�WxH�WHc H� �D�`H�H)�H������ H�G�@#�� H�HH�GH�,�Ic�L�$� H��@ �� H�p�F % = ukH�H�p H���<���H��H�CN�l ��E ����������� @�ƃ�@��t_H��xZ��H�U�E I�mLcL�#H��[]A\A]�f. � � H���3���H���f D �C���H�SH���@��� � H��H���u����H��H�5 ' ����H�=' 1����f D � �AUATUSH��H��H�GxH�P�H�WxH�WHc H� �D�`H�H)�H������ H�G�@#�� H�HH�GH�,�Ic�L�$� H��@ �� H�p�F % = u[H�H�p H��謋��H�SLc �E N�l"�������u`��� tW��L�E�E I�mLcL�#H��[]A\A]� � � H����H���f D ����H�SH���P��� � L��H��H�����H��H�5�% �ъ��H�=�% 1�裋�� � �AUATUH��H��SH��H�ExL�e H�MH�P�H�UxHc H�4��PL��H)�H������ Hc�I��H��@ �x H�p�F % = u;H�L�h I�E H�x H�XtDL��H���R���H�H9�u9L�e H��[]A\A]� @ � H�����I��I�E H�x H�Xu�1�H9�t�L��H������I�E H�x H�XtL��H�����H�H)�H��� H�E L)�H��H9�}5� f. � � H��裉��I�D$H�sH��I��融��I�$1�L��H�����H��H���6���H�CHcPH�p���t �Du�� H���L����f. � L�@M��t�L��H���\����f. � L��L��H��H��� ���I���H�5�# ���H�=�# 1����� �ATUSH�GxH��H�P�H�WxH�WHc H� hH�H)�H������ Hc�H��L�$� �@ tbH�p�F % = u@H�H�p 1�H��识��H��H���t���H��H��虉��H�SH��LcL�#[]A\� D � ����H���H�=7# 1�����H��H�5,$ ���� @ � �AWAVAUATUSH��H��H��H�CxH�+H�KH�P�H�SxHc H�4��PH��H)�H������ Hc�L�}�H��@ � H�p�F % = �� H�L�h I�} �� H�C�@#�� H�PH�CL�$�M�uH�� L��H��H�� M�M��L�D$HD��t���H�T$H��H�����A�D$@�� H�C L)�H���� M�gI�} �� A� ��L��H�C H)�H��~IK�4�H��L�}I�����H�EM9e }�L�;H��[]A\A]A^A_Ð� H��蓄��I������ H��H�� H��资��H���H��舉��I������I��� L��L��� H��腄��I��H�h�A���f � L��H���U�������H�5�! �4���H�=V 1�����f D � �AVAUATUSH�GxH��L�'H�P�H�WxH�WHc H� �D�hL��H)�H������ H�GM�t$��@#�� H�HH�GH�,�Mc�J��@ �� H�p�F % = uMH�H�@ �H(H�H��H��脇���E �E � @ ujH�C L)�H��~>I�nL�#[]A\A]A^�f D � H���#���뫐�;���H�SH���n��� � L��L��� H���5���I��L�`� @ H��H��� ����H��H�5� ���H�=w 1�辅��ff. � � �AUATUSH��H��H�GxH�P�H�WxH�WHc H��hD�a(H� �H�H)�H������ Hc�H��L�,� �@ �� H�p�F % = ugH�H�@ A��A��H�A��A��t[��u6�0H��装��H��H���h���H�SH��LkL�+H��[]A\A]�f D H�0H��� ����� � ���� @ �0�H�=o 1�趄��H��H�5[ �ǃ�� � � �AWL�� H��1�AVH� � H�� AUL�=�* L�5�* ATL�%U���L�-n_ UH�����SH�����H�d���H�5� H��D$�Q���H�ڑ��H�5� H���;���H�D���H�5� H���%���L��H�5~ H������L��H�5u H��H� �@( ���L��H�5e H��H� L�%@����@( �ԃ��L��H�5L H��H� �@( 踃��L��H�5= H��H� L�%��@( 蕃��L��H�5( H��H� �@( �y���L��H�5 H��H� L�%r����@( �V���H�߰��H�5 H��H� �@( �6���H�����H�5� H��� ���H�����H�5� H��� ���H�ӎ��H�5� H����H�����H�5� H���ނ��H�Ǵ��H�5� H���Ȃ��H�����H�5� H��貂��H���H�5� H��蜂��L��H�5� H��节��L��H�5� H��H� L�%�����@( �g���L��H�5� H��H� �@( �K���L��H�5� H��H� �@( �/���L��H�5t H��H� L�%����@( � ���H�����H�5[ H��H� �@( ���H����H�5M H���ց��L��H�5D H���ā��L��H�5A H��H� �@( 訁��L��H�55 H��H� �@(+ 茁��L��H�5) H��H� �@( �p���L��H�5 H��H� �@( �T���L��H�5 H��H� �@( �8���L��H�5� H��H� �@( � ���L��H�5� H��H� �@(. � ���L��H�5� H��H� �@(- ���L��H�5� H��H� �@(* �Ȁ��L��H�5� H��H� �@( 謀��L��H�5� H��H� �@( 萀��L��H�5� H��H� �@( �t���L��H�5� H��H� �@( �X���L��H�5� H��H� �@(, �<���L��H�5� H��H� �@(! � ���L��H�5� H��H� �@( ����L��H�5x H��H� �@( ����L��H�5l H��H� �@( ����L��H�5` H��H� �@( ���L��H�5U H��H� �@(5 ���L��H�5L H��H� �@(6 �x��L��H�5B H��H� �@(8 �\��L��H�52 H��H� �@( �@��L��H�5# H��H� �@( �$��L��H�5 H��H� �@(2 ���L��H�5 H��H� �@(3 ��~��L��H�5� H��H� �@( ��~��L��H�5� H��H� �@( �~��L��H�5� H��H� �@( �~��L��H�5� H��H� �@(4 �|~��L��H�5� H��H� �@( �`~��L��H�5� H��H� �@( �D~��L��H�5� H��H� �@(0 �(~��L��H�5� H��H� �@( � ~��L��H�5� H��H� �@( ��}��L��H�5x H��H� �@(/ ��}��L��H�5i H��H� �@( �}��L��H�5[ H��H� �@(1 �}��L��H�5K H��H� �@( �}��L��H�5; H��H� �@( �d}��L��H�5, H��H� �@(( �H}��L��H�5 H��H� �@( �,}��L��H�5 H��H� �@(' �}��L��H�5 H��H� �@( ��|��L��H�5� H��H� �@( ��|��L��H�5� H��H� �@( �|��L��H�5� H��H� �@(7 �|��L��H�5� H��H� �@(" �|��L��H�5� H��H� �@( �h|��L��H�5� H��H� �@($ �L|��L��H�5� H��H� �@(# �0|��L��H�5� H��H� �@(% �|��L��H�5� H��H� �@(& �{��L��H�5� H��H� �@() ��{��L��H�5� H��H� �@( �{��L��H�5� H��H� L�%�����@( �{��H���H�5h H��H� �@( �}{��H����H�5V H���g{��H����H�5T H���Q{��L��H�5X H���?{��L��H�5S H��H� �@(�����#{��L��H�5F H��H� �@( � �{��L��H�55 H��H� �@( ��z��L��H�5' H��H� �@( ��z��L��H�5 H��H� L�%����@( �z��H����H�5� H��H� �@(� �z��H�Ս��H�5� H���vz��L��H�5� H���dz��L��H�5� H��H� �@( �Hz��L��H�5� H��H� �@( �,z��L��H�5� H��H� �@(\ �z��L��H�5� H��H� �@(@ ��y��L��H�5� H��H� �@(P ��y��L��H�5� H��H� �@(X �y��L��H�5� H��H� �@( �y��L��H�5� H��H� �@( �y��L��H�5w H��H� �@(( �hy��L��H�5g H��H� �@( �Ly��L��H�5V H��H� �@( �0y��L��H�5K H��H� �@(x �y��L��H�5B H��H� �@(p �x��L��H�54 H��H� �@(h ��x��L��H�5( H��H� �@(` �x��L��H�5 H��H� �@(� �x��L��H�5 H��H� �@(� �x��L��H�5� H��H� �@( �lx��L��H�5� H��H� �@(H �Px��L��H�5� H��H� �@(8 �4x��L��H�5� H��H� �@(@ �x��L��H�5� H��H� �@(X �w��L��H�5� H��H� �@(P ��w��L��H�5� H��H� �@( ��w��L��H�5� H��H� �@( �w��L��H�5� H��H� �@(( �w��L��H�5z H��H� �@( �pw��L��H�5i H��H� �@( �Tw��L��H�5[ H��H� �@(@ �8w��L��H�5P H��H� �@(8 � w��L��H�5E H��H� �@(0 � w��L��H�57 H��H� L�%����@(H ��v��L��H�5% H��H� �@( �v��L��H�5 H��H� L�%Z����@( �v��H����H�5 H��H� �@( �~v��L��H�5� H���lv��L��H�5� H��H� �@( �Pv��L��H�5� H��H� �@( �4v��L��H�5� H��H� L�%����@( �v��H�����H�5� H��H� �@( ��u��L��H�5� H����u��L��H�5� H��H� �@( ��u��L��H�5� H��H� �@( �u��L��H�5� H��H� L�%@����@( �u��H���H�5y H��H� �@( �du��L��H�5l H���Ru��L��H�5j H��H� �@( �6u��L��H�5_ H��H� �@( �u��L��H�5W H��H� �@( �t��L��H�5I H��H� �@( ��t��L��H�5? H��H� �@( ��t��L��H�51 H��H� �@( �t��L��H�5% H��H� �@( �t��L��H�5 H��H� L�%W����@( �kt��H�D���H�5 H��H� �@( �Kt��H��H�5� H���5t��L��H�5� H���#t��L��H�5� H��H� �@( �t��L��H�5� H��H� L�%���@( ��s��L��H�5� H��H� �@( ��s��L��H�5� H��H� L�%����@( �s��H�����H�5� H��H� �@( �s��L��H�5� H���ss��L��H�5� H��H� �@(( �Ws��L��H�5u H��H� �@( �;s��L��H�5f H��H� �@( � s��L��H�5U H��H� �@(8 �s��L��H�5E H��H� �@(0 ��r��L��H�59 H��H� �@( ��r��L��H�5' H��H� �@( �r��L��H�5 H��H� L�%�����@( �r��H�����H�5� H��H� �@( �lr��H�Ս��H�5� H���Vr��H�?���H�5� H���@r��H����H�5� H���*r��H�#��H�5� H���r��H�]��H�5� H���q��H���H�5� H����q��H�����H�5� H����q��H�����H�5� H���q��L��H�5� H���q��L��H�5� H��H� L�%C����@( �q��H�Б��H�5� H��H� �@( �gq��H��H�5r H���Qq��H����H�5k H���;q��L��H�5f H���)q��L��H�5` H��H� L�%����@( �q��H���H�5H H��H� �@( ��p��H�_��H�58 H����p��H�ٻ��H�5, H���p��H�c�H�5& H���p��H���H�5 H���p��H���H�5 H���xp��L��H�5 H���fp��L��H�5 H��H� L�%?����@( �Cp��H���H�5� H��H� �@( �#p��H�<�H�5� H��� p��L��H�5� H���o��L��H�5� H��H� L�%��@( ��o��H��H�5� H��H� �@( �o��H���H�5� H���o��H�����H�5� H���o��H�����H�5� H���vo��H�Ϙ��H�5� H���`o��H�9���H�5� H���Jo��L��H�5� H���8o��L��H�5� H��H� �@( � o��L��H�5�+ H��H� �@( � o��L��H�5� H��H� �@( ��n��L��H�5� H��H� �@( ��n��L��H�5� H��H� �@(( �n��L��H�5| H��H� �@( �n��L��L��H��H� �@( �xn��L��H�5l H��H� �@( �\n��H�5�L��H��H� �@( �@n��H�����H�5V H���*n��� H�5T H���Fp��� H�5D H��I���?o��H�����H��H���}o��� L��H��I��H� �#z��H��H�p�'k��H��H��H���)m���� �f�I�uH��I���n��A�M�I�U�L��I��H����y��H��H�p��j��H��H��H����l��I�} u�L��H��H� � �wk��H��H H�5�t ��j��H��P H��H��H�PH��h L��8 H�PH�!t L�%�u��H�5a L�@H�P H��s H� H�P(H��� H�P8L��H�@0 L�D$�l��H��L��H��H� H�5 �@( �l��H��L��H��H� H�5 �@(� �l��H��L��H��H� H�5� �@(� �dl��H��L��H��H� H�5� �@(0 �El��H��L��H��H� H�5� �@(� �&l��H��L��H��H� H�5� �@( �l��H��L��H��H� H�5� �@(� ��k��H��L��H��H� H�5� �@(� ��k��H��L��H��H� H�5� �@(� �k��H��L��H��H� H�5v �@(H �k��H��L��H��H� H�5c �@(� �lk��H�� H�5S H� �@(� �.k��H�T$H�� H���yk��L��H�� A� � ��j��A� H�� � H�5 I���j��L��H�� H���)k��A� H�� � H�5� �j��L��H�� H���j��L��H�� A� � �\j��A� H�� � H�5� I���:j��L��H�� H���j��H��A� � � H�5� �j��A� H�� � H�5o I����i��L��H�� H���Sj��H��A� � � H�5�& �i��H��A� � � H�5�& I���i��H��L�� H���i���t$H��H��[]A\A]A^A_�5h�� � �H��H��� B::SPECIAL B::PADLIST B::NULL argument is not a reference i sv is not a reference argument is not SvROK B::MAGIC gv is not a reference format format is not a reference cv is not a reference he he is not a reference padlist is not a reference B::PADNAMELIST padlist, idx B::PADNAME pnl pnl is not a reference pnl, idx pn pn is not a reference op, method op is not a reference opnum pp_%s 0x%lx \' \\ \n \r \t \a \b \f \v \%03o \" \$ \@ nrftaebx\ mg mg is not a reference B::overlay PL_ppaddr[OP_%s] B::RHE method %s not implemented o, cv %ld,%ld ,%c ??? NULL gp in B::GV::%s io, name stdin io is not a reference stdout stderr Invalid value '%s' av is not a reference av, idx hv hv is not a reference h is not a reference 1.80 v5.32.0 B.c B::formfeed B::amagic_generation B::comppadlist B::sv_no B::sv_undef B::sv_yes B::main_root B::main_start B::dowarn B::sub_generation B::walkoptree B::walkoptree_debug B::address B::svref_2object B::opnumber B::ppname B::hash B::cast_I32 B::minus_c B::save_BEGINs B::cchar B::cstring B::perlstring B::threadsv_names B::CLONE B::BINOP::last B::COP::arybase B::COP::cop_seq B::COP::file B::COP::filegv B::COP::hints B::COP::hints_hash B::COP::io B::COP::label B::COP::line B::COP::stash B::COP::stashoff B::COP::stashpv B::COP::warnings B::LISTOP::children B::LOGOP::other B::LOOP::lastop B::LOOP::nextop B::LOOP::redoop B::METHOP::first B::METHOP::meth_sv B::METHOP::rclass B::OP::desc B::OP::flags B::OP::folded B::OP::moresib B::OP::name B::OP::next B::OP::opt B::OP::parent B::OP::ppaddr B::OP::private B::OP::savefree B::OP::sibling B::OP::size B::OP::slabbed B::OP::spare B::OP::static B::OP::targ B::OP::type B::PADOP::gv B::PADOP::padix B::PADOP::sv B::PMOP::code_list B::PMOP::pmflags B::PMOP::pmoffset B::PMOP::pmregexp B::PMOP::pmreplroot B::PMOP::pmreplstart B::PMOP::pmstash B::PMOP::pmstashpv B::PMOP::precomp B::PMOP::reflags B::PVOP::pv B::SVOP::gv B::SVOP::sv B::UNOP::first B::OP::oplist B::UNOP_AUX::string B::UNOP_AUX::aux_list B::SV::FLAGS B::SV::MAGICAL B::SV::POK B::SV::REFCNT B::SV::ROK B::SV::SvTYPE B::SV::object_2svref B::IV::IV B::AV::MAX B::BM::USEFUL B::CV::CvFLAGS B::CV::FILE B::CV::OUTSIDE B::CV::OUTSIDE_SEQ B::CV::STASH B::GV::GvFLAGS B::GV::STASH B::HV::KEYS B::HV::MAX B::IO::BOTTOM_GV B::IO::BOTTOM_NAME B::IO::FMT_GV B::IO::FMT_NAME B::IO::IoFLAGS B::IO::IoTYPE B::IO::LINES B::IO::LINES_LEFT B::IO::PAGE B::IO::PAGE_LEN B::IO::TOP_GV B::IO::TOP_NAME B::IV::IVX B::IV::UVX B::NV::NVX B::PV::CUR B::PV::LEN B::PVLV::TARG B::PVLV::TARGLEN B::PVLV::TARGOFF B::PVLV::TYPE B::PVMG::SvSTASH B::IV::needs64bits B::IV::packiv B::NV::NV B::REGEXP::REGEX B::REGEXP::compflags B::REGEXP::precomp B::REGEXP::qr_anoncv B::PV::RV B::BM::TABLE B::PV::PV B::PV::PVBM B::PV::PVX B::PVMG::MAGIC B::MAGIC::FLAGS B::MAGIC::LENGTH B::MAGIC::MOREMAGIC B::MAGIC::OBJ B::MAGIC::PRIVATE B::MAGIC::PTR B::MAGIC::REGEX B::MAGIC::TYPE B::MAGIC::precomp B::BM::PREVIOUS B::BM::RARE B::GV::FILE B::GV::NAME B::HV::NAME B::GV::isGV_with_GP B::GV::is_empty B::GV::GP B::GV::AV B::GV::CV B::GV::CVGEN B::GV::EGV B::GV::FORM B::GV::GvREFCNT B::GV::HV B::GV::IO B::GV::SV B::GV::LINE B::GV::GPFLAGS B::GV::FILEGV B::IO::IsSTD B::AV::FILL B::AV::ARRAY B::AV::ARRAYelt B::FM::LINES B::CV::CONST B::CV::ROOT B::CV::START B::CV::DEPTH B::CV::PADLIST B::CV::HSCXT B::CV::XSUB B::CV::XSUBANY B::CV::const_sv B::CV::GV B::CV::NAME_HEK B::HV::FILL B::HV::RITER B::HV::ARRAY B::HE::SVKEY_force B::HE::VAL B::HE::HASH B::RHE::HASH B::PADLIST::MAX B::PADNAMELIST::MAX B::PADLIST::NAMES B::PADLIST::ARRAY B::PADLIST::ARRAYelt B::PADLIST::REFCNT B::PADNAMELIST::ARRAY B::PADNAMELIST::ARRAYelt B::PADLIST::id B::PADLIST::outid B::PADNAME::COP_SEQ_RANGE_LOW B::PADNAME::LEN B::PADNAME::OURSTASH B::PADNAME::REFCNT B::PADNAME::TYPE B::PADNAMELIST::REFCNT B::PADNAME::PV B::PADNAME::FLAGS B:: B::EXPORT_OK HEf_SVKEY B.xs B::init_av B::check_av B::unitcheck_av B::begin_av B::end_av B::main_cv B::inc_gv B::defstash B::curstash B::regex_padav B::warnhook B::diehook B::OP::does_parent B::PADNAME::SvSTASH B::PADNAME::PROTOCV B::PADNAME::PVX B::PADNAME::PARENT_PAD_INDEX SVTYPEMASK SVt_PVGV SVt_PVHV PAD_FAKELEX_ANON PAD_FAKELEX_MULTI SVpad_STATE SVpad_TYPED SVpad_OUR CXTYPEMASK CXt_NULL CXt_WHEN CXt_BLOCK CXt_GIVEN CXt_LOOP_ARY CXt_LOOP_LAZYSV CXt_LOOP_LAZYIV CXt_LOOP_LIST CXt_LOOP_PLAIN CXt_SUB CXt_FORMAT CXt_EVAL CXt_SUBST CXp_MULTICALL CXp_HASARGS CXp_SUB_RE CXp_SUB_RE_FAKE CXp_REAL CXp_TRYBLOCK CXp_FOR_DEF CXp_FOR_LVREF CXp_FOR_GV CXp_FOR_PAD CXp_ONCE G_SCALAR G_ARRAY G_VOID G_WANT G_DISCARD G_EVAL G_NOARGS G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL G_UNDEF_FILL G_WRITING_TO_STDERR G_RE_REPARSING G_METHOD_NAMED G_RETHROW EVAL_NULL EVAL_INEVAL EVAL_WARNONLY EVAL_KEEPERR EVAL_INREQUIRE PERLSI_UNDEF PERLSI_MAIN PERLSI_MAGIC PERLSI_SORT PERLSI_SIGNAL PERLSI_OVERLOAD PERLSI_DESTROY PERLSI_WARNHOOK PERLSI_DIEHOOK PERLSI_REQUIRE PERLSI_MULTICALL PERLSI_REGCOMP CVf_METHOD CVf_LVALUE CVf_CONST CVf_ISXSUB CVf_WEAKOUTSIDE CVf_CLONE CVf_CLONED CVf_ANON CVf_UNIQUE CVf_NODEBUG CVf_CVGV_RC CVf_DYNFILE CVf_AUTOLOAD CVf_HASEVAL CVf_NAMED CVf_LEXICAL CVf_ANONCONST GVf_INTRO GVf_MULTI GVf_ASSUMECV GVf_IMPORTED GVf_IMPORTED_SV GVf_IMPORTED_AV GVf_IMPORTED_HV GVf_IMPORTED_CV OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST OPf_KIDS OPf_PARENS OPf_REF OPf_MOD OPf_STACKED OPf_SPECIAL OPf_FOLDED PMf_HAS_ERROR PMf_RETAINT PMf_ONCE PMf_USED PMf_CONST PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_NONDESTRUCT PMf_HAS_CV PMf_CODELIST_PRIVATE PMf_IS_QR PMf_USE_RE_EVAL PMf_WILDCARD OA_MARK OA_FOLDCONST OA_RETSCALAR OA_TARGET OA_TARGLEX OA_OTHERINT OA_DANGEROUS OA_DEFGV OCSHIFT OA_CLASS_MASK OA_BASEOP OA_UNOP OA_BINOP OA_LOGOP OA_LISTOP OA_PMOP OA_SVOP OA_PADOP OA_PVOP_OR_SVOP OA_LOOP OA_COP OA_BASEOP_OR_UNOP OA_FILESTATOP OA_LOOPEXOP OA_METHOP OA_UNOP_AUX OASHIFT OA_SCALAR OA_LIST OA_AVREF OA_HVREF OA_CVREF OA_FILEREF OA_SCALARREF OA_OPTIONAL PERL_LOADMOD_DENY PERL_LOADMOD_NOIMPORT PERL_LOADMOD_IMPORT_OPS BHKf_bhk_start BHKf_bhk_pre_end BHKf_bhk_post_end BHKf_bhk_eval RV2CVOPCV_MARK_EARLY RV2CVOPCV_RETURN_NAME_GV RV2CVOPCV_RETURN_STUB RV2CVOPCV_FLAG_MASK OP_LVALUE_NO_CROAK XOPf_xop_name XOPf_xop_desc XOPf_xop_class XOPf_xop_peep MDEREF_reload MDEREF_AV_pop_rv2av_aelem MDEREF_AV_vivify_rv2av_aelem MDEREF_AV_padav_aelem MDEREF_AV_gvav_aelem MDEREF_HV_pop_rv2hv_helem MDEREF_HV_vivify_rv2hv_helem MDEREF_HV_padhv_helem MDEREF_HV_gvhv_helem MDEREF_ACTION_MASK MDEREF_INDEX_none MDEREF_INDEX_const MDEREF_INDEX_padsv MDEREF_INDEX_gvsv MDEREF_INDEX_MASK MDEREF_FLAG_last MDEREF_MASK MDEREF_SHIFT OPpARGELEM_SV OPpLVREF_SV OPpARG1_MASK OPpCOREARGS_DEREF1 OPpENTERSUB_INARGS OPpPADHV_ISKEYS OPpRV2HV_ISKEYS OPpSORT_NUMERIC OPpTRANS_CAN_FORCE_UTF8 OPpARGELEM_AV OPpCONST_NOVER OPpCOREARGS_DEREF2 OPpEVAL_HAS_HH OPpFT_ACCESS OPpHINT_STRICT_REFS OPpITER_REVERSED OPpSORT_INTEGER OPpTRANS_USE_SVOP OPpARG2_MASK OPpAVHVSWITCH_MASK OPpARGELEM_HV OPpASSIGN_TRUEBOOL OPpCONST_SHORTCIRCUIT OPpDONT_INIT_GV OPpENTERSUB_HASTARG OPpEVAL_UNICODE OPpFT_STACKED OPpLVREF_ELEM OPpSLICEWARNING OPpSORT_REVERSE OPpSPLIT_IMPLIM OPpTRANS_IDENTICAL OPpARGELEM_MASK OPpARG3_MASK OPpPADRANGE_COUNTSHIFT OPpCONST_STRICT OPpENTERSUB_AMPER OPpEVAL_BYTES OPpFT_STACKING OPpITER_DEF OPpLVREF_ITER OPpMAYBE_LVSUB OPpMULTICONCAT_STRINGIFY OPpREVERSE_INPLACE OPpSORT_INPLACE OPpSPLIT_LEX OPpTRANS_SQUASH OPpARG4_MASK OPpASSIGN_COMMON_AGG OPpCONST_ENTERED OPpDEREF_AV OPpEVAL_COPHH OPpFT_AFTER_t OPpLVREF_AV OPpMAYBE_TRUEBOOL OPpMULTIDEREF_EXISTS OPpOPEN_IN_RAW OPpSORT_DESCEND OPpSPLIT_ASSIGN OPpSUBSTR_REPL_FIRST OPpTARGET_MY OPpASSIGN_COMMON_RC1 OPpDEREF_HV OPpEARLY_CV OPpEVAL_RE_REPARSING OPpHUSH_VMSISH OPpKVSLICE OPpLVREF_HV OPpMAY_RETURN_CONSTANT OPpMULTICONCAT_FAKE OPpMULTIDEREF_DELETE OPpOPEN_IN_CRLF OPpTRANS_COMPLEMENT OPpTRUEBOOL OPpDEREF OPpDEREF_SV OPpLVREF_CV OPpLVREF_TYPE OPpALLOW_FAKE OPpASSIGN_BACKWARDS OPpASSIGN_COMMON_SCALAR OPpCONCAT_NESTED OPpCONST_BARE OPpCOREARGS_SCALARMOD OPpENTERSUB_DB OPpEXISTS_SUB OPpFLIP_LINENUM OPpINDEX_BOOLNEG OPpLIST_GUESSED OPpLVAL_DEFER OPpMULTICONCAT_APPEND OPpOPEN_OUT_RAW OPpOUR_INTRO OPpPAD_STATE OPpREFCOUNTED OPpREPEAT_DOLIST OPpSLICE OPpSORT_STABLE OPpTRANS_GROWS OPpPADRANGE_COUNTMASK OPpASSIGN_CV_TO_GV OPpCOREARGS_PUSHMARK OPpENTERSUB_NOPAREN OPpLVALUE OPpLVAL_INTRO OPpOFFBYONE OPpOPEN_OUT_CRLF OPpPV_IS_UTF8 OPpSORT_UNSTABLE OPpTRANS_DELETE RXf_PMf_STD_PMMOD_SHIFT RXf_PMf_MULTILINE RXf_PMf_SINGLELINE RXf_PMf_FOLD RXf_PMf_EXTENDED RXf_PMf_EXTENDED_MORE RXf_PMf_NOCAPTURE RXf_PMf_KEEPCOPY RXf_PMf_CHARSET RXf_PMf_STRICT RXf_PMf_SPLIT PADNAMEt_OUTER PADNAMEt_STATE PADNAMEt_LVALUE PADNAMEt_TYPED PADNAMEt_OUR RXf_NO_INPLACE_SUBST RXf_EVAL_SEEN RXf_UNBOUNDED_QUANTIFIER_SEEN RXf_CHECK_ALL RXf_MATCH_UTF8 RXf_USE_INTUIT_NOML RXf_USE_INTUIT_ML RXf_INTUIT_TAIL RXf_IS_ANCHORED RXf_COPY_DONE RXf_TAINTED_SEEN RXf_TAINTED RXf_START_ONLY RXf_SKIPWHITE RXf_WHITE RXf_NULL SVf_IOK SVf_NOK SVf_POK SVf_ROK SVp_IOK SVp_NOK SVp_POK SVp_SCREAM SVf_PROTECT SVs_PADTMP SVs_PADSTALE SVs_TEMP SVs_OBJECT SVs_GMG SVs_SMG SVs_RMG SVf_FAKE SVf_OOK SVf_BREAK SVf_READONLY SVf_AMAGIC SVf_IsCOW SVf_UTF8 SVf_IVisUV SVs_PADMY B::OP B::UNOP B::BINOP B::LOGOP B::LISTOP B::PMOP B::SVOP B::PADOP B::PVOP B::LOOP B::COP B::METHOP B::UNOP_AUX B::IV B::NV B::PV B::INVLIST B::PVIV B::PVNV B::PVMG B::REGEXP B::GV B::PVLV B::AV B::HV B::CV B::FM B::IO Couldn't add key '%s' to %%B:: REGEX is only meaningful on r-magic precomp is only meaningful on r-magic Illegal alias %d for B::*OP::next Illegal type 0x%x for B::*OP::%s Illegal alias 0x%08x for B::*IVX argument to B::BM::TABLE is not a PVBM Illegal alias 0x%08x for B::*SV B::PADNAME::COP_SEQ_RANGE_HIGH B::PADNAME::PARENT_FAKELEX_FLAGS MDEREF_AV_gvsv_vivify_rv2av_aelem MDEREF_AV_padsv_vivify_rv2av_aelem MDEREF_HV_gvsv_vivify_rv2hv_helem MDEREF_HV_padsv_vivify_rv2hv_helem �v���v���v���v���v���v���v���v���v��uv��jv��_v��Tv��Iv��>v��3v��(v�� v��v��v���u���u���u���u���u��Uz��Nz��Bz��:z��/z��'z��sy��ky���z���z��By��7y���x���x���x���x��~���}���}��t}��<~���}��}��o���X���A���*��������������D���<���d�������ĉ�����������������@�������������������Ӑ��S���Ӑ��Ӑ��Ӑ��Ӑ��Ӑ��Ӑ�� ���Ӑ��Ӑ��Ӑ��Ӑ��Ӑ��Ӑ��Ӑ��Ӑ��Ӑ��Ӑ��Ӑ��Ӑ������Ӑ������i���Ӑ��L���F���F���������������������Ӑ��z���z���4���4���Ք����������ʓ������{��������ӕ�����]���4���*������������������������������������������������������������������ ���G���;���/���#���(�����������x�������x����������� ���P������ ������P�������p���8���8����������������� ���p����������� ( 0 8 8 8 ` 0 0 0 P X 8 8 ;� R p6��� �;��� @A��� JA��\ B��� �B��4 �D��� �G��� H�� �H��X `I��� J��� �J��� �J��� PK�� L��l �L��� pM��� PN�� @O��P PP��� Q��� PR��� �S��4 pT��` �U��� �V��� �V��� X��8 0Y��t pZ��� �[��� �\��( ^��d P_��� �`��� �a�� �b��\ d��� e��� 0g��< `h��x �i��� Pk�� �l��@ �m��p �o��� �p�� �q��X x��� ���� �d �� ����� Є��� ���� ��| ���� �� ���� 0���� p���� ��� ��L ����� ���� p��� ���< ����| `���� ���� P���( �t �� ����� ���, @���h ���� �� �� 0���` @���� zR x � $ �3��p FJ w� ?:*3$" D �8��` 8 \ ?��� B�B�D �D(�G0\ (D ABBH H � t?��� B�B�B �B(�D0�A8�D@� 8D0A(B BBBI � �=�� @������ H �@�� B�B�E �E(�D0�A8�GP� 8D0A(B BBBF , P �C��p F�A�A �X ABA 8 � �C��� F�B�A �A(�G0� (A ABBF ( � pD��� E�A�G c AAA 8 � �D��� F�B�A �A(�G0� (A ABBA $ HE��x l < �E��@ t( P �E��} E�A�J P AAA P | 0F��� B�H�E �K(�A0�D8�DHBPFHA@I 8D0A(B BBBF ( � �F��� E�A�G b AAA 8 � �F��� F�B�A �A(�G0� (A ABBE < 8 �G��� F�B�B �A(�A0�� (A BBBA 8 x 4H��� F�B�A �A(�G0� (A ABBD 8 � �H�� F�B�A �A(�J0� (A ABBH ( � �I��� F�A�J i ABC < @J��B F�B�B �A(�A0�� (A BBBG 8 \ PK��Z F�B�A �A(�G0� (A ABBD ( � tL��� E�A�J p AAF H � M��< F�B�B �B(�A0�A8�J@� 8A0A(B BBBG 8 �M��$ F�B�A �A(�G0� (A ABBI L �N�� 8 ` �N�� F�A�A �� ABG e ABH 8 � �O��- F�B�A �A(�G0� (A ABBC 8 � �P��: F�B�A �A(�G0� (A ABBJ 8 �Q��: F�B�A �A(�G0� (A ABBI 8 P �R��$ F�B�A �A(�G0� (A ABBI 8 � �S��2 F�B�A �A(�G0� (A ABBF < � �T��# F�B�B �A(�A0�� (A BBBG 8 �U��5 F�B�A �A(�G0� (A ABBH < D �V�� F�B�B �A(�A0�� (A BBBG 8 � �W��5 F�B�A �A(�G0� (A ABBH 8 � �X��- F�B�A �A(�G0� (A ABBD < � �Y��� F�B�B �A(�A0�� (A BBBJ ` < @Z�� F�B�E �A(�A0�� (A BBBJ t (A BBBE n (A BBBK 8 � �[��' F�B�A �A(�G0� (A ABBI H � �\��r F�B�B �B(�A0�A8�JP� 8A0A(B BBBI < ( ^��o F�B�B �A(�A0�� (A BBBH 8 h D_��: F�B�A �A(�G0� (A ABBB , � H`��� F�A�A �� ABE H � a��! F�B�B �B(�A0�A8�GP� 8A0A(B BBBI H �b��0 F�B�B �E(�A0�A8�DP� 8A0A(B BBBE L l �c��� F�B�B �A(�A0�w (A BBBF L (A BBBA H � �d��! F�B�B �B(�A0�A8�J`� 8A0A(B BBBJ H tj��� F�B�H �B(�A0�A8�D`y 8A0A(B BBBE p T �q��= F�B�B �A(�A0�� (A BBBB j (A BBBG \ (A BBBE V (A BBBC , � �s��� F�A�A �� ABI � Tt��� L�� 8 �t�� F�B�A �A(�G0� (A ABBC , P �u��� F�A�A �� ABH < � �v��+ F�B�B �A(�A0�� (A BBBD � �1�� 0����� , � \y��' F�A�A �� ABF , \z��� F�A�A �� ABF ( @ {��� E�A�J � AAD x l �{��b F�B�B �B(�A0�A8�Gp�xH�J�B�Xp@xH�QxApe 8A0A(B BBBA �xG�VxAp H � ����1 F�B�B �B(�A0�A8�G@� 8A0A(B BBBI H 4 ����� F�E�B �B(�A0�A8�D`� 8A0A(B BBBB , � ����� F�A�A �� ABA 8 � ����� F�B�A �A(�G0� (A ABBI 8 � ���D F�B�A �A(�G@� (A ABBG 8 ( 4���b F�B�A �A(�G0� (A ABBE 8 d h���� F�B�A �A(�J0� (A ABBJ < � ܔ��\ F�E�B �A(�A0�� (A BBBC , � ����� F�A�A �� ABK < ����� F�B�B �A(�A0�� (A BBBJ 8 P ���M F�B�A �A(�G0� (A ABBG H � ���� F�B�B �B(�A0�A8�JP� 8A0A(B BBBD L � t���� F�B�B �A(�A0�� (A BBBC � (A BBBI ( ( $���� E�A�J n AAH 8 T ����J F�B�A �A(�G0� (A ABBK 8 � ̝��= F�B�A �A(�G0� (A ABBH 8 � О��� F�B�A �G(�D0� (A ABBE , t���� F�A�A �� ABF H 8 ���� F�B�B �B(�A0�A8�JP, 8A0A(B BBBB < � ����B F�B�B �A(�A0�� (A BBBG 8 � ȣ�� F�B�A �A(�G0� (A ABBG H ���� F�N�P �P(�O0�I8�DP�8D0A(B BBB �[ �[ �3 �� � , > J V ` k t } � � � � � � � � � � @ & � 6 ? @ L X f @ q � } � � � � � � � � � @ � � � � � ( 2 < H V c � r � � � � � � � � � * 5 ? J Z d @ o � x � � � � � @ � � � � � � � � " 2 @ B � R [ i y � � � � � @ � � � � � � � � @ � % . > I ^ h @ x � � � � � � � � @ � � � � � � " * 2 ; K S Z l z � � � � � � � � � � � � 5 D U g u � � � � � � � ' � ! � " A ^ t � ! @ " � � � � � # 6 0 H 0 Z @ k w � � � � � � � � ' 6 I X e y � � � � � � � ' 7 E S c s � � � � � � � � # 2 K ^ n { � � � � � � � � ( 8 H ] j � � � � � � � � " 6 B 0 K 0 W 0 c 0 q @ @ � @ � @ � @ � @ � @ � @ � @ @ @ . @ < @ R @ b @ o @ | @ � @ � @ � @ � @ � � � � � � � � , � 8 � I � W � h � x � � � � � � � @ � + � � � � � � � @ � / 9 H W g v � � � � � � � @ � ' 5 F R a o @ y � � � � � � � � @ � � � � � � � � @ � & 0 = H R [ � f � � d� �� " � # Y� ( 2� 0 � 0 � G� 8 7� @ '� H �� @ �� X �� ( � ( �� ( O� < �� $ {� 8 � 8 l� _� 0 �� �� �� ( .� D� �� � p� � I� � � *� � N� N� �� � _� �� ?� �� �� �� :� � V� �� �� � Y� j� � }� � p v ~ � � � � � � � � � � � � � � � � % - 3 9 ? E - = P �� p3 x3 ���o � 0 ] �\ `? � �+ ���o ���o P ���o �o � ���o � �Z 0P @P PP `P pP �P �P �P �P �P �P �P �P Q Q Q 0Q @Q PQ `Q pQ �Q �Q �Q �Q �Q �Q �Q �Q R R R 0R @R PR `R pR �R �R �R �R �R �R �R �R S S S 0S @S PS `S pS �S �S �S �S �S �S �S �S T T T 0T @T PT `T pT �T �T �T �T �T �T �T �T U U U 0U @U PU `U pU �U ����B.so-5.32.1-481.1.el9_6.x86_64.debug ��KN�7zXZ �ִF ! t/����] ?�E�h=��ڊ�2N� ����i��e��1C�*�V ��H�K��C���<R�:=�ڍ� ��r0-���Zem|E_�� ��%~�A�}���;� b��N5��Qڇ~K%C<�B��?C�+�Wg��\�C�˅��'2�-!M���t�#�*+��ꌏch����8�&\_"�`��6ŝb���}��vp>�Fg��誅!9����t�e�ٗ�'.a'�� yd�uVm � vf�O � .+��ۓ�nS�"�af'��er9S�m�S3e��y��`"��!��H< �2?�Z����d��9�K)i�VL�@#J�$���߹.h�A���'���j���m�g�j'��VK�O�{�q m[b~f��F�r��/]_���0e�<b�$���M��mIƜ�t�bl���^E���F1�WX�HXE�"js��q�Q�} �u@�7��J���]�-_�LPϵ����D��B .M� u� � ��3�@B��R_�VA�\��[�l���E�5wD�����W�.�scoi�$a!f����"�c� 4� CQI� ��Ω@��B�S}�E h�'a�|�Xޝ�**�P4>�n�d�.+Y� Hä���kY��2�WW [�G'����_�!E+"�ܙ�C�@h��q�e^�5�m%oûb��j�N��[S ����m��HM���鲋�1�h 0T�.�! �� ��X��^�jKQ\餟^Qy+�&�$L'_���'$�� U��B��p����`d���; g[�}ᣞ;�n� Miُ�ܝ�В`OT��3��*�\T�>�.� �a*L�߯�MY �)�I��W�.��Vqq*�gL��6�d ��K��?�,�6�Y�KRC/y�X�;n:l������E�C���G� �Jd:�Wɷ䛥k���߯�n�����3nc� �0.�E�]#��!UN�|�L �G2^��2���3<��$���q5��� |�mXhWv���� ,=����Tc�{yz~�E�Yk�uf*�6Ɨ�v=1m�D�,��P��&�u��G�. ��2 mn�lq�>�/�vQY#�Ho�Ӫ��G�B�=�o���=@�_ s�Zm�3�j�Q˙� ��6a�Gt2�I�'�p�D�s���0�w��**��p������6Fu[�� �H�m JS��AN_���؛�W��`��g� �q�1����z����@��N��Y�o��M��w���� +gԦV*ҷ�8R���lX - ��o2��0 fF�$ _�Q����a�m�8S��/`��&F��C��T�1f u�����D8y��9��� ` hXO�[7c�p�)����JP�>/����7�] F,6l���bB �]��W�� qsk6�z��[����eO�� .NQ��1_g6i8��.��,r��sȴW��E ��o��mH�l����`����"�Iğ Z]�؎�nP8��JO�����7(T��Jlw)#ÖC�Q*�h�WdըP�ٍ#��A^3Մ-9m)2�, ":�?� m�o�~�M� ��ŀ��oW_�z���J`_���O�X��$~��]��k����BgDo�nſ ߇�c�K@I3�a���Ԫ Je�(䌛���-�1��f���-uVG�W�mP�5\.��/5ꤩ4�r�L=/fi�hY��SF.#�;��qC.�f��R��F@O��c�8e$;~QnQ�/Ǎ� ao}l/N} � �5 �sb#��g� YZ .shstrtab .note.gnu.property .note.gnu.build-id .gnu.hash .dynsym .dynstr .gnu.version .gnu.version_r .rela.dyn .rela.plt .init .plt.sec .text .fini .rodata .eh_frame_hdr .eh_frame .init_array .fini_array .data.rel.ro .dynamic .got .data .bss .gnu_debuglink .gnu_debugdata � � � � $ 1 ���o � � $ ; C 0 0 ] K ���o � � � X ���o P P 0 g � � �+ q B `? `? { P P v P P p � �U �U ` � �Z �Z � � �� �� � � � �) � � � � � P P L � p3 p3 � x3 x3 � �3 �3 `' � �Z �Z � � �\ �\ � ` ` � ` ` � ` , 0` � ,g
| ver. 1.6 |
Github
|
.
| PHP 8.2.30 | ??????????? ?????????: 0.09 |
proxy
|
phpinfo
|
???????????