116359Sasami# B::Deparse.pm 216359Sasami# Copyright (c) 1998-2000, 2002, 2003, 2004, 2005, 2006 Stephen McCamant. 316359Sasami# All rights reserved. 416359Sasami# This module is free software; you can redistribute and/or modify 516359Sasami# it under the same terms as Perl itself. 616359Sasami 716359Sasami# This is based on the module of the same name by Malcolm Beattie, 816359Sasami# but essentially none of his code remains. 916359Sasami 1016359Sasamipackage B::Deparse 1.74; 1116359Sasamiuse strict; 1216359Sasamiuse Carp; 1316359Sasamiuse B qw(class main_root main_start main_cv svref_2object opnumber perlstring 1416359Sasami OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST 1516359Sasami OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPf_PARENS 1616359Sasami OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpKVSLICE 1716359Sasami OPpCONST_BARE OPpEMPTYAVHV_IS_HV 1816359Sasami OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY 1916359Sasami OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST 2016359Sasami OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE 2116359Sasami OPpSPLIT_ASSIGN OPpSPLIT_LEX 2216359Sasami OPpPADHV_ISKEYS OPpRV2HV_ISKEYS 2316359Sasami OPpCONCAT_NESTED 2416359Sasami OPpMULTICONCAT_APPEND OPpMULTICONCAT_STRINGIFY OPpMULTICONCAT_FAKE 2516359Sasami OPpTRUEBOOL OPpINDEX_BOOLNEG OPpDEFER_FINALLY 2616359Sasami OPpARG_IF_UNDEF OPpARG_IF_FALSE 2716359Sasami SVf_IOK SVf_NOK SVf_ROK SVf_POK SVf_FAKE SVs_RMG SVs_SMG 2816359Sasami SVs_PADTMP 2916359Sasami CVf_NOWARN_AMBIGUOUS CVf_LVALUE 3016359Sasami PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE 3116359Sasami PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED PMf_EXTENDED_MORE 3216359Sasami PADNAMEf_OUTER PADNAMEf_OUR PADNAMEf_TYPED 3350477Speter MDEREF_reload 3416359Sasami MDEREF_AV_pop_rv2av_aelem 3545816Skato MDEREF_AV_gvsv_vivify_rv2av_aelem 3616359Sasami MDEREF_AV_padsv_vivify_rv2av_aelem 3716359Sasami MDEREF_AV_vivify_rv2av_aelem 3816359Sasami MDEREF_AV_padav_aelem 3931778Seivind MDEREF_AV_gvav_aelem 4016359Sasami MDEREF_HV_pop_rv2hv_helem 4146871Skato MDEREF_HV_gvsv_vivify_rv2hv_helem 4254407Skato MDEREF_HV_padsv_vivify_rv2hv_helem 4358888Skato MDEREF_HV_vivify_rv2hv_helem 4416359Sasami MDEREF_HV_padhv_helem 4516359Sasami MDEREF_HV_gvhv_helem 4616359Sasami MDEREF_ACTION_MASK 4716359Sasami MDEREF_INDEX_none 4816359Sasami MDEREF_INDEX_const 4916359Sasami MDEREF_INDEX_padsv 5016359Sasami MDEREF_INDEX_gvsv 5116359Sasami MDEREF_INDEX_MASK 5216359Sasami MDEREF_FLAG_last 5316359Sasami MDEREF_MASK 5416359Sasami MDEREF_SHIFT 5516359Sasami ); 5616359Sasami 5716359Sasamiour $AUTOLOAD; 5816359Sasamiuse warnings (); 5916359Sasamirequire feature; 6016359Sasami 6116359Sasamiuse Config; 6216359Sasami 6316359SasamiBEGIN { 6416359Sasami # List version-specific constants here. 6516359Sasami # Easiest way to keep this code portable between version looks to 6616359Sasami # be to fake up a dummy constant that will never actually be true. 6716359Sasami foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER 6816359Sasami OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE 6916359Sasami PMf_CHARSET PMf_KEEPCOPY PMf_NOCAPTURE CVf_ANONCONST 7016359Sasami CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST 7116359Sasami PMf_NONDESTRUCT OPpEVAL_BYTES 7216359Sasami OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV 7316359Sasami OPpLVREF_CV OPpLVREF_ELEM SVpad_STATE)) { 7416359Sasami eval { B->import($_) }; 7516359Sasami no strict 'refs'; 7616359Sasami *{$_} = sub () {0} unless *{$_}{CODE}; 7740565Sbde } 7840565Sbde} 7940565Sbde 8016359Sasami# Todo: 8116359Sasami# (See also BUGS section at the end of this file) 8216359Sasami# 8316359Sasami# - finish tr/// changes 8416359Sasami# - add option for even more parens (generalize \&foo change) 8516359Sasami# - left/right context 8616359Sasami# - copy comments (look at real text with $^P?) 8716359Sasami# - avoid semis in one-statement blocks 8816359Sasami# - associativity of &&=, ||=, ?: 8916359Sasami# - ',' => '=>' (auto-unquote?) 9016359Sasami# - break long lines ("\r" as discretionary break?) 9116359Sasami# - configurable syntax highlighting: ANSI color, HTML, TeX, etc. 9216359Sasami# - more style options: brace style, hex vs. octal, quotes, ... 9316359Sasami# - print big ints as hex/octal instead of decimal (heuristic?) 9416359Sasami# - handle 'my $x if 0'? 9516359Sasami# - version using op_next instead of op_first/sibling? 9616359Sasami# - avoid string copies (pass arrays, one big join?) 9716359Sasami# - here-docs? 9816359Sasami 9916359Sasami# Current test.deparse failures 10016359Sasami# comp/hints 6 - location of BEGIN blocks wrt. block openings 10116359Sasami# run/switchI 1 - missing -I switches entirely 10216359Sasami# perl -Ifoo -e 'print @INC' 10316359Sasami# op/caller 2 - warning mask propagates backwards before warnings::register 10416359Sasami# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register' 10516359Sasami# op/getpid 2 - can't assign to shared my() declaration (threads only) 10640565Sbde# 'my $x : shared = 5' 10740565Sbde# op/override 7 - parens on overridden require change v-string interpretation 10816359Sasami# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6' 10916359Sasami# c.f. 'BEGIN { *f = sub {0} }; f 2' 11042262Skato# op/pat 774 - losing Unicode-ness of Latin1-only strings 11142262Skato# 'use charnames ":short"; $x="\N{latin:a with acute}"' 11242262Skato# op/recurse 12 - missing parens on recursive call makes it look like method 11354174Snyan# 'sub f { f($x) }' 11454174Snyan# op/subst 90 - inconsistent handling of utf8 under "use utf8" 11554174Snyan# op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open 11642262Skato# op/tiehandle compile - "use strict" deparsed in the wrong place 11716359Sasami# uni/tr_ several 11842262Skato# ext/B/t/xref 11 - line numbers when we add newlines to one-line subs 11942262Skato# ext/Data/Dumper/t/dumper compile 12042262Skato# ext/DB_file/several 12142262Skato# ext/Encode/several 12242262Skato# ext/Ernno/Errno warnings 12342262Skato# ext/IO/lib/IO/t/io_sel 23 12442262Skato# ext/PerlIO/t/encoding compile 12542262Skato# ext/POSIX/t/posix 6 12642262Skato# ext/Socket/Socket 8 12742262Skato# ext/Storable/t/croak compile 12842262Skato# lib/Attribute/Handlers/t/multi compile 12942262Skato# lib/bignum/ several 13042262Skato# lib/charnames 35 13142262Skato# lib/constant 32 13242262Skato# lib/English 40 13342262Skato# lib/ExtUtils/t/bytes 4 13442262Skato# lib/File/DosGlob compile 13573022Snyan# lib/Filter/Simple/t/data 1 13642262Skato# lib/Math/BigInt/t/constant 1 13742262Skato# lib/Net/t/config Deparse-warning 13842262Skato# lib/overload compile 13916359Sasami# lib/Switch/ several 14016359Sasami# lib/Symbol 4 14116359Sasami# lib/Test/Simple several 14276212Skato# lib/Term/Complete 14365877Skato# lib/Tie/File/t/29_downcopy 5 14416359Sasami# lib/vars 22 14516359Sasami 14624132Sbde# Object fields: 14738297Skato# 14816359Sasami# in_coderef2text: 14976212Skato# True when deparsing via $deparse->coderef2text; false when deparsing the 15076212Skato# main program. 15176212Skato# 15276212Skato# avoid_local: 15376212Skato# (local($a), local($b)) and local($a, $b) have the same internal 15476212Skato# representation but the short form looks better. We notice we can 15576212Skato# use a large-scale local when checking the list, but need to prevent 15616359Sasami# individual locals too. This hash holds the addresses of OPs that 15776212Skato# have already had their local-ness accounted for. The same thing 15845783Skato# is done with my(). 15945783Skato# 16058477Skato# curcv: 16145226Skato# CV for current sub (or main program) being deparsed 16216359Sasami# 16316359Sasami# curcvlex: 16416359Sasami# Cached hash of lexical variables for curcv: keys are 16522407Skato# names prefixed with "m" or "o" (representing my/our), and 16616359Sasami# each value is an array with two elements indicating the cop_seq 16745783Skato# of scopes in which a var of that name is valid and a third ele- 16842262Skato# ment referencing the pad name. 16945783Skato# 17058888Skato# curcop: 17158888Skato# COP for statement being deparsed 17258888Skato# 17358888Skato# curstash: 17416359Sasami# name of the current package for deparsed code 17545783Skato# 17645783Skato# subs_todo: 17785302Simp# array of [cop_seq, CV, is_format?, name] for subs and formats we still 17845783Skato# want to deparse. The fourth element is a pad name thingy for lexical 17916359Sasami# subs or a string for special blocks. For other subs, it is undef. For 18077962Snyan# lexical subs, CV may be undef, indicating a stub declaration. 18116359Sasami# 18277962Snyan# protos_todo: 18342265Skato# as above, but [name, prototype] for subs that never got a GV 18477962Snyan# 18577962Snyan# subs_done, forms_done: 18642265Skato# keys are addresses of GVs for subs and formats we've already 18716359Sasami# deparsed (or at least put into subs_todo) 18816359Sasami# 18916359Sasami# subs_declared 19016359Sasami# keys are names of subs for which we've printed declarations. 19116359Sasami# That means we can omit parentheses from the arguments. It also means we 19216359Sasami# need to put CORE:: on core functions of the same name. 19316359Sasami# 19416359Sasami# in_subst_repl 19516359Sasami# True when deparsing the replacement part of a substitution. 19616359Sasami# 19716359Sasami# in_refgen 19816359Sasami# True when deparsing the argument to \. 19916359Sasami# 20016359Sasami# parens: -p 20116359Sasami# linenums: -l 20245783Skato# unquote: -q 20345783Skato# cuddle: ' ' or '\n', depending on -sC 20445783Skato# indent_size: -si 20516359Sasami# use_tabs: -sT 20616359Sasami# ex_const: -sv 20745783Skato 20845783Skato# A little explanation of how precedence contexts and associativity 20945783Skato# work: 21046766Skato# 21145783Skato# deparse() calls each per-op subroutine with an argument $cx (short 21245783Skato# for context, but not the same as the cx* in the perl core), which is 21345783Skato# a number describing the op's parents in terms of precedence, whether 21445783Skato# they're inside an expression or at statement level, etc. (see 21545783Skato# chart below). When ops with children call deparse on them, they pass 21645783Skato# along their precedence. Fractional values are used to implement 21745783Skato# associativity ('($x + $y) + $z' => '$x + $y + $y') and related 21845783Skato# parentheses hacks. The major disadvantage of this scheme is that 21916359Sasami# it doesn't know about right sides and left sides, so say if you 22042265Skato# assign a listop to a variable, it can't tell it's allowed to leave 22142265Skato# the parens off the listop. 22260472Snyan 22316359Sasami# Precedences: 22416359Sasami# 26 [TODO] inside interpolation context ("") 22560472Snyan# 25 left terms and list operators (leftward) 22660472Snyan# 24 left -> 22760472Snyan# 23 nonassoc ++ -- 22860472Snyan# 22 right ** 22960472Snyan# 21 right ! ~ \ and unary + and - 23016359Sasami# 20 left =~ !~ 23116359Sasami# 19 left * / % x 23216359Sasami# 18 left + - . 23316359Sasami# 17 left << >> 23416359Sasami# 16 nonassoc named unary operators 23516359Sasami# 15 nonassoc < > <= >= lt gt le ge 23616359Sasami# 14 nonassoc == != <=> eq ne cmp 23716359Sasami# 13 left & 23851654Sphk# 12 left | ^ 23916359Sasami# 11 left && 24016359Sasami# 10 left || 24116359Sasami# 9 nonassoc .. ... 24216359Sasami# 8 right ?: 24316359Sasami# 7 right = += -= *= etc. 24416359Sasami# 6 left , => 24516359Sasami# 5 nonassoc list operators (rightward) 24616359Sasami# 4 right not 24716359Sasami# 3 left and 24816359Sasami# 2 left or xor 24916359Sasami# 1 statement modifiers 25016359Sasami# 0.5 statements, but still print scopes as do { ... } 25116359Sasami# 0 statement level 25216359Sasami# -1 format body 25316359Sasami 25425026Skato# Nonprinting characters with special meaning: 25516359Sasami# \cS - steal parens (see maybe_parens_unop) 25616359Sasami# \n - newline and indent 25716359Sasami# \t - increase indent 25816359Sasami# \b - decrease indent ('outdent') 25916359Sasami# \f - flush left (no indent) 26016359Sasami# \cK - kill following semicolon, if any 26116359Sasami 26216359Sasami# Semicolon handling: 26316359Sasami# - Individual statements are not deparsed with trailing semicolons. 26416359Sasami# (If necessary, \cK is tacked on to the end.) 26516359Sasami# - Whatever code joins statements together or emits them (lineseq, 26616359Sasami# scopeop, deparse_root) is responsible for adding semicolons where 26716359Sasami# necessary. 26816359Sasami# - use statements are deparsed with trailing semicolons because they are 26916359Sasami# immediately concatenated with the following statement. 27016359Sasami# - indent() removes semicolons wherever it sees \cK. 27116359Sasami 27216359Sasami 27316359SasamiBEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem 27416359Sasami kvaslice kvhslice padsv argcheck 27516359Sasami nextstate dbstate rv2av rv2hv helem pushdefer leavetrycatch 27616359Sasami custom ]) { 27716359Sasami eval "sub OP_\U$_ () { " . opnumber($_) . "}" 27816359Sasami}} 27916359Sasami 28016359Sasami# _pessimise_walk(): recursively walk the optree of a sub, 28116359Sasami# possibly undoing optimisations along the way. 28245783Skato 28316359Sasamisub DEBUG { 0 } 28416359Sasamiuse if DEBUG, 'Data::Dumper'; 28516359Sasami 28616359Sasamisub _pessimise_walk { 28716359Sasami my ($self, $startop) = @_; 28816359Sasami 28925026Skato return unless $$startop; 29016359Sasami my ($op, $prevop); 29116359Sasami for ($op = $startop; $$op; $prevop = $op, $op = $op->sibling) { 29227479Skato my $ppname = $op->name; 29316359Sasami 29416359Sasami # pessimisations start here 29516359Sasami 29616359Sasami if ($ppname eq "padrange") { 29716359Sasami # remove PADRANGE: 29816359Sasami # the original optimisation either (1) changed this: 29916359Sasami # pushmark -> (various pad and list and null ops) -> the_rest 30016359Sasami # or (2), for the = @_ case, changed this: 30116359Sasami # pushmark -> gv[_] -> rv2av -> (pad stuff) -> the_rest 30216359Sasami # into this: 30316359Sasami # padrange ----------------------------------------> the_rest 30416359Sasami # so we just need to convert the padrange back into a 30516359Sasami # pushmark, and in case (1), set its op_next to op_sibling, 30616359Sasami # which is the head of the original chain of optimised-away 30716359Sasami # pad ops, or for (2), set it to sibling->first, which is 30816359Sasami # the original gv[_]. 30916359Sasami 31016359Sasami $B::overlay->{$$op} = { 31116359Sasami type => OP_PUSHMARK, 31216359Sasami name => 'pushmark', 31316359Sasami private => ($op->private & OPpLVAL_INTRO), 31416359Sasami }; 31516359Sasami } 31616359Sasami 31716359Sasami # pessimisations end here 31816359Sasami 31943663Skato if (class($op) eq 'PMOP') { 32016359Sasami if (ref($op->pmreplroot) 32116359Sasami && ${$op->pmreplroot} 32243663Skato && $op->pmreplroot->isa( 'B::OP' )) 32343663Skato { 32416359Sasami $self-> _pessimise_walk($op->pmreplroot); 32516359Sasami } 32616359Sasami 32716359Sasami # pessimise any /(?{...})/ code blocks 32860472Snyan my ($re, $cv); 32960472Snyan my $code_list = $op->code_list; 33060472Snyan if ($$code_list) { 33116359Sasami $self->_pessimise_walk($code_list); 33216359Sasami } 33316359Sasami elsif (${$re = $op->pmregexp} && ${$cv = $re->qr_anoncv}) { 33416359Sasami $code_list = $cv->ROOT # leavesub 33516359Sasami ->first # qr 33660472Snyan ->code_list; # list 33716359Sasami $self->_pessimise_walk($code_list); 33816359Sasami } 33916359Sasami } 34016359Sasami 34116359Sasami if ($op->flags & OPf_KIDS) { 34216359Sasami $self-> _pessimise_walk($op->first); 34316359Sasami } 34416359Sasami 34554174Snyan } 34654174Snyan} 34754174Snyan 34816359Sasami 34916359Sasami# _pessimise_walk_exe(): recursively walk the op_next chain of a sub, 35016359Sasami# possibly undoing optimisations along the way. 35116359Sasami 35216359Sasamisub _pessimise_walk_exe { 35316359Sasami my ($self, $startop, $visited) = @_; 35416359Sasami 35516359Sasami no warnings 'recursion'; 35616359Sasami 35732332Skato return unless $$startop; 35816359Sasami return if $visited->{$$startop}; 35916359Sasami my ($op, $prevop); 36016359Sasami for ($op = $startop; $$op; $prevop = $op, $op = $op->next) { 36116359Sasami last if $visited->{$$op}; 36216359Sasami $visited->{$$op} = 1; 36316359Sasami my $ppname = $op->name; 36416359Sasami if ($ppname =~ 36516359Sasami /^((and|d?or)(assign)?|(map|grep)while|range|cond_expr|once)$/ 36616359Sasami # entertry is also a logop, but its op_other invariably points 36716359Sasami # into the same chain as the main execution path, so we skip it 36816359Sasami ) { 36916359Sasami $self->_pessimise_walk_exe($op->other, $visited); 37017256Sasami } 37116359Sasami elsif ($ppname eq "subst") { 37217256Sasami $self->_pessimise_walk_exe($op->pmreplstart, $visited); 37345226Skato } 37416359Sasami elsif ($ppname =~ /^(enter(loop|iter))$/) { 37516359Sasami # redoop and nextop will already be covered by the main block 37616359Sasami # of the loop 37716359Sasami $self->_pessimise_walk_exe($op->lastop, $visited); 37816359Sasami } 37916359Sasami 38051202Snyan # pessimisations start here 38151202Snyan } 38254407Skato} 38368360Snyan 38451202Snyan# Go through an optree and "remove" some optimisations by using an 38516359Sasami# overlay to selectively modify or un-null some ops. Deparsing in the 38642262Skato# absence of those optimisations is then easier. 38742262Skato# 38842262Skato# Note that older optimisations are not removed, as Deparse was already 38943663Skato# written to recognise them before the pessimise/overlay system was added. 39043663Skato 39142262Skatosub pessimise { 39242262Skato my ($self, $root, $start) = @_; 39342262Skato 39416359Sasami no warnings 'recursion'; 39516359Sasami # walk tree in root-to-branch order 39642262Skato $self->_pessimise_walk($root); 39716359Sasami 39816359Sasami my %visited; 39916359Sasami # walk tree in execution order 40046871Skato $self->_pessimise_walk_exe($start, \%visited); 40116359Sasami} 40258888Skato 40352831Snyan 40445783Skatosub null { 40520129Sasami my $op = shift; 40616359Sasami return class($op) eq "NULL"; 40716359Sasami} 40843663Skato 40916359Sasami 41045783Skato# Add a CV to the list of subs that still need deparsing. 41116359Sasami 41216359Sasamisub todo { 41371713Snyan my $self = shift; 41458888Skato my($cv, $is_form, $name) = @_; 41552831Snyan my $cvfile = $cv->FILE//''; 41616359Sasami return unless ($cvfile eq $0 || exists $self->{files}{$cvfile}); 41743663Skato my $seq; 41816359Sasami if ($cv->OUTSIDE_SEQ) { 41951654Sphk $seq = $cv->OUTSIDE_SEQ; 42016359Sasami } elsif (!null($cv->START) and is_state($cv->START)) { 42116359Sasami $seq = $cv->START->cop_seq; 42216359Sasami } else { 42316359Sasami $seq = 0; 42452831Snyan } 42552831Snyan my $stash = $cv->STASH; 42654407Skato if (class($stash) eq 'HV') { 42752831Snyan $self->{packs}{$stash->NAME}++; 42852831Snyan } 42916359Sasami push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form, $name]; 43058888Skato} 43158888Skato 43258888Skato 43358888Skato# Pop the next sub from the todo list and deparse it 43458888Skato 43558888Skatosub next_todo { 43671713Snyan my $self = shift; 43771713Snyan my $ent = shift @{$self->{'subs_todo'}}; 43871713Snyan my ($seq, $cv, $is_form, $name) = @$ent; 43916359Sasami 44016359Sasami # any 'use strict; package foo' that should come before the sub 44145783Skato # declaration to sync with the first COP of the sub 44245783Skato my $pragmata = ''; 44345783Skato if ($cv and !null($cv->START) and is_state($cv->START)) { 44416359Sasami $pragmata = $self->pragmata($cv->START); 44552831Snyan } 44645783Skato 44752831Snyan if (ref $name) { # lexical sub 44852831Snyan # emit the sub. 44945783Skato my @text; 45045783Skato my $flags = $name->FLAGS; 45116359Sasami my $category = 45216359Sasami !$cv || $seq <= $name->COP_SEQ_RANGE_LOW 45352831Snyan ? $self->keyword($flags & PADNAMEf_OUR 45445783Skato ? "our" 45552831Snyan : $flags & SVpad_STATE 45645783Skato ? "state" 45745783Skato : "my") . " " 45845783Skato : ""; 45952831Snyan 46052831Snyan # Skip lexical 'state' subs imported from the builtin:: 46152831Snyan # package, since they are created automatically by 46252831Snyan # use builtin "foo" 46352831Snyan if ($cv && $category =~ /\bstate\b/) { 46452831Snyan my $globname; 46552831Snyan my $gv = $cv->GV; 46652831Snyan if ( 46752831Snyan $gv 46852831Snyan && defined (($globname = $gv->object_2svref)) 46952831Snyan && $$globname =~ /^\*builtin::/ 47052831Snyan ) { 47152831Snyan return ''; 47252831Snyan } 47352831Snyan } 47458888Skato 47552831Snyan push @text, $category; 47658888Skato 47758888Skato # XXX We would do $self->keyword("sub"), but ���my CORE::sub��� 47858888Skato # doesn���t work and ���my sub��� ignores a &sub in scope. I.e., 47958888Skato # we have a core bug here. 48058888Skato push @text, "sub " . substr $name->PVX, 1; 48158888Skato if ($cv) { 48258888Skato # my sub foo { } 48358888Skato push @text, " " . $self->deparse_sub($cv); 48458888Skato $text[-1] =~ s/ ;$/;/; 48558888Skato } 48658888Skato else { 48758888Skato # my sub foo; 48858888Skato push @text, ";\n"; 48958888Skato } 49058888Skato return $pragmata . join "", @text; 49158888Skato } 49216359Sasami 49316359Sasami my $gv = $cv->GV; 49416359Sasami $name //= $self->gv_name($gv); 49516359Sasami if ($is_form) { 49616359Sasami return $pragmata . $self->keyword("format") . " $name =\n" 49716359Sasami . $self->deparse_format($cv). "\n"; 49838603Skato } else { 49947625Sphk my $use_dec; 50047625Sphk if ($name eq "BEGIN") { 50147625Sphk $use_dec = $self->begin_is_use($cv); 50247625Sphk if (defined ($use_dec) and $self->{'expand'} < 5) { 50347625Sphk return $pragmata if 0 == length($use_dec); 50447625Sphk 50551654Sphk # XXX bit of a hack: Test::More's use_ok() method 50647625Sphk # builds a fake use statement which deparses as, e.g. 50747625Sphk # use Net::Ping (@{$args[0];}); 50847625Sphk # As well as being superfluous (the use_ok() is deparsed 50947625Sphk # too) and ugly, it fails under use strict and otherwise 51047625Sphk # makes use of a lexical var that's not in scope. 51147625Sphk # So strip it out. 51272793Skato return $pragmata 51372793Skato if $use_dec =~ 51416359Sasami m/ 51516359Sasami \A 51645783Skato use \s \S+ \s \(\@\{ 51726478Skato ( 51845816Skato \s*\#line\ \d+\ \".*"\s* 51945783Skato )? 52045816Skato \$args\[0\];\}\); 52116359Sasami \n 52224655Skato \Z 52366250Skato /x; 52446766Skato 52566250Skato $use_dec =~ s/^(use|no)\b/$self->keyword($1)/e; 52645783Skato } 52746766Skato } 52872431Skato my $l = ''; 52972431Skato if ($self->{'linenums'}) { 53016359Sasami my $line = $gv->LINE; 53116359Sasami my $file = $gv->FILE; 53229715Skato $l = "\n\f#line $line \"$file\"\n"; 53329715Skato } 53453373Snyan my $p = ''; 53516359Sasami my $stash; 53616359Sasami if (class($cv->STASH) ne "SPECIAL") { 53716359Sasami $stash = $cv->STASH->NAME; 53816359Sasami if ($stash ne $self->{'curstash'}) { 53916359Sasami $p = $self->keyword("package") . " $stash;\n"; 54016359Sasami $name = "$self->{'curstash'}::$name" unless $name =~ /::/; 54142262Skato $self->{'curstash'} = $stash; 54216359Sasami } 54342262Skato } 54416359Sasami if ($use_dec) { 54516359Sasami return "$pragmata$p$l$use_dec"; 54616359Sasami } 54716359Sasami if ( $name !~ /::/ and $self->lex_in_scope("&$name") 54816359Sasami || $self->lex_in_scope("&$name", 1) ) 54916359Sasami { 55016359Sasami $name = "$self->{'curstash'}::$name"; 55116359Sasami } elsif (defined $stash) { 55253373Snyan $name =~ s/^\Q$stash\E::(?!\z|.*::)//; 55360472Snyan } 55453373Snyan my $ret = "$pragmata${p}${l}" . $self->keyword("sub") . " $name " 55542262Skato . $self->deparse_sub($cv); 55616359Sasami $self->{'subs_declared'}{$name} = 1; 55716359Sasami return $ret; 55816359Sasami } 55916359Sasami} 56016359Sasami 56116359Sasami 56216359Sasami# Return a "use" declaration for this BEGIN block, if appropriate 56316359Sasamisub begin_is_use { 56416359Sasami my ($self, $cv) = @_; 56516359Sasami my $root = $cv->ROOT; 56616359Sasami local @$self{qw'curcv curcvlex'} = ($cv); 56716359Sasami local $B::overlay = {}; 56816359Sasami $self->pessimise($root, $cv->START); 56916359Sasami#require B::Debug; 57016359Sasami#B::walkoptree($cv->ROOT, "debug"); 57116359Sasami my $lineseq = $root->first; 57216359Sasami return if $lineseq->name ne "lineseq"; 57316359Sasami 57416359Sasami my $req_op = $lineseq->first->sibling; 57516359Sasami return if $req_op->name ne "require"; 57616359Sasami 57716359Sasami # maybe it's C<require expr> rather than C<require 'foo'> 57816359Sasami return if ($req_op->first->name ne 'const'); 57945783Skato 58054174Snyan my $module; 58154174Snyan if ($req_op->first->private & OPpCONST_BARE) { 58216359Sasami # Actually it should always be a bareword 58360472Snyan $module = $self->const_sv($req_op->first)->PV; 58416359Sasami $module =~ s[/][::]g; 58516359Sasami $module =~ s/.pm$//; 58616359Sasami } 58716359Sasami else { 58816359Sasami $module = $self->const($self->const_sv($req_op->first), 6); 58916359Sasami } 59016359Sasami 59116359Sasami my $version; 59216359Sasami my $version_op = $req_op->sibling; 59316359Sasami return if class($version_op) eq "NULL"; 59416359Sasami if ($version_op->name eq "lineseq") { 59516359Sasami # We have a version parameter; skip nextstate & pushmark 59616359Sasami my $constop = $version_op->first->next->next; 59716359Sasami 59816359Sasami return unless $self->const_sv($constop)->PV eq $module; 59916359Sasami $constop = $constop->sibling; 60016359Sasami $version = $self->const_sv($constop); 60116359Sasami if (class($version) eq "IV") { 60242262Skato $version = $version->int_value; 60343539Skato } elsif (class($version) eq "NV") { 60443539Skato $version = $version->NV; 60543539Skato } elsif (class($version) ne "PVMG") { 60643539Skato # Includes PVIV and PVNV 60743539Skato $version = $version->PV; 60843539Skato } else { 60943539Skato # version specified as a v-string 61043539Skato $version = 'v'.join '.', map ord, split //, $version->PV; 61143539Skato } 61243539Skato $constop = $constop->sibling; 61343539Skato return if $constop->name ne "method_named"; 61443539Skato return if $self->meth_sv($constop)->PV ne "VERSION"; 61543539Skato } 61643539Skato 61743539Skato $lineseq = $version_op->sibling; 61843539Skato return if $lineseq->name ne "lineseq"; 61943539Skato my $entersub = $lineseq->first->sibling; 62043539Skato if ($entersub->name eq "stub") { 62143539Skato return "use $module $version ();\n" if defined $version; 62243539Skato return "use $module ();\n"; 62316359Sasami } 62442262Skato return if $entersub->name ne "entersub"; 62543539Skato 62643539Skato # See if there are import arguments 62743539Skato my $args = ''; 62843539Skato 62943539Skato my $svop = $entersub->first->sibling; # Skip over pushmark 63043539Skato return unless $self->const_sv($svop)->PV eq $module; 63142262Skato 63242262Skato # Pull out the arguments 63343539Skato for ($svop=$svop->sibling; index($svop->name, "method_") != 0; 63443539Skato $svop = $svop->sibling) { 63543539Skato $args .= ", " if length($args); 63643539Skato $args .= $self->deparse($svop, 6); 63743539Skato } 63843539Skato 63943539Skato my $use = 'use'; 64043539Skato my $method_named = $svop; 64143539Skato return if $method_named->name ne "method_named"; 64216359Sasami my $method_name = $self->meth_sv($method_named)->PV; 64342262Skato 64443539Skato if ($method_name eq "unimport") { 64543539Skato $use = 'no'; 64643539Skato } 64743539Skato 64843539Skato # Certain pragmas are dealt with using hint bits, 64943539Skato # so we ignore them here 65043539Skato if ($module eq 'strict' || $module eq 'integer' 65143539Skato || $module eq 'bytes' || $module eq 'warnings' 65243539Skato || $module eq 'feature') { 65343539Skato return ""; 65443539Skato } 65543539Skato 65643539Skato if (defined $version && length $args) { 65716359Sasami return "$use $module $version ($args);\n"; 65842262Skato } elsif (defined $version) { 65943539Skato return "$use $module $version;\n"; 66043539Skato } elsif (length $args) { 66143539Skato return "$use $module ($args);\n"; 66243539Skato } else { 66343539Skato return "$use $module;\n"; 66443539Skato } 66543539Skato} 66643539Skato 66743539Skatosub stash_subs { 66843539Skato my ($self, $pack, $seen) = @_; 66943539Skato my (@ret, $stash); 67043539Skato if (!defined $pack) { 67143539Skato $pack = ''; 67243539Skato $stash = \%::; 67342262Skato } 67442262Skato else { 67543539Skato $pack =~ s/(::)?$/::/; 67643539Skato no strict 'refs'; 67743539Skato $stash = \%{"main::$pack"}; 67843539Skato } 67943539Skato return 68043539Skato if ($seen ||= {})->{ 68143539Skato $INC{"overload.pm"} ? overload::StrVal($stash) : $stash 68243539Skato }++; 68343539Skato my $stashobj = svref_2object($stash); 68443539Skato my %stash = $stashobj->ARRAY; 68543539Skato while (my ($key, $val) = each %stash) { 68643539Skato my $flags = $val->FLAGS; 68743539Skato if ($flags & SVf_ROK) { 68843539Skato # A reference. Dump this if it is a reference to a CV. If it 68943539Skato # is a constant acting as a proxy for a full subroutine, then 69043539Skato # we may or may not have to dump it. If some form of perl- 69143539Skato # space visible code must have created it, be it a use 69243539Skato # statement, or some direct symbol-table manipulation code that 69343539Skato # we will deparse, then we don���t want to dump it. If it is the 69442262Skato # result of a declaration like sub f () { 42 } then we *do* 69542262Skato # want to dump it. The only way to distinguish these seems 69642262Skato # to be the SVs_PADTMP flag on the constant, which is admit- 69742262Skato # tedly a hack. 69842262Skato my $class = class(my $referent = $val->RV); 69942262Skato if ($class eq "CV") { 70042262Skato $self->todo($referent, 0); 70142262Skato } elsif ( 70242262Skato $class !~ /^(AV|HV|CV|FM|IO|SPECIAL)\z/ 70342262Skato # A more robust way to write that would be this, but B does 70442262Skato # not provide the SVt_ constants: 70542262Skato # ($referent->FLAGS & B::SVTYPEMASK) < B::SVt_PVAV 70642262Skato and $referent->FLAGS & SVs_PADTMP 70742262Skato ) { 70842262Skato push @{$self->{'protos_todo'}}, [$pack . $key, $val]; 70942262Skato } 71042262Skato } elsif ($flags & (SVf_POK|SVf_IOK)) { 71142262Skato # Just a prototype. As an ugly but fairly effective way 71242262Skato # to find out if it belongs here is to see if the AUTOLOAD 71342262Skato # (if any) for the stash was defined in one of our files. 71442262Skato my $A = $stash{"AUTOLOAD"}; 71542262Skato if (defined ($A) && class($A) eq "GV" && defined($A->CV) 71642262Skato && class($A->CV) eq "CV") { 71742262Skato my $AF = $A->FILE; 71842262Skato next unless $AF eq $0 || exists $self->{'files'}{$AF}; 71916359Sasami } 72016359Sasami push @{$self->{'protos_todo'}}, 72116359Sasami [$pack . $key, $flags & SVf_POK ? $val->PV: undef]; 72216359Sasami } elsif (class($val) eq "GV") { 72316359Sasami if (class(my $cv = $val->CV) ne "SPECIAL") { 72416359Sasami next if $self->{'subs_done'}{$$val}++; 72516359Sasami 72616359Sasami # Ignore imposters (aliases etc) 72716359Sasami my $name = $cv->NAME_HEK; 72816359Sasami if(defined $name) { 72916359Sasami # avoid using $cv->GV here because if the $val GV is 73016359Sasami # an alias, CvGV() could upgrade the real stash entry 73116359Sasami # from an RV to a GV 73216359Sasami next unless $name eq $key; 73316359Sasami next unless $$stashobj == ${$cv->STASH}; 73416359Sasami } 73516359Sasami else { 73616359Sasami next if $$val != ${$cv->GV}; 73785149Snyan } 73816359Sasami 73916359Sasami $self->todo($cv, 0); 74016359Sasami } 74116359Sasami if (class(my $cv = $val->FORM) ne "SPECIAL") { 74216359Sasami next if $self->{'forms_done'}{$$val}++; 74316359Sasami next if $$val != ${$cv->GV}; # Ignore imposters 74442262Skato $self->todo($cv, 1); 74542262Skato } 74642262Skato if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) { 74742262Skato $self->stash_subs($pack . $key, $seen); 74842262Skato } 74942262Skato } 75042262Skato } 75142262Skato} 75242262Skato 75342262Skatosub print_protos { 75442262Skato my $self = shift; 75542262Skato my $ar; 75642262Skato my @ret; 75742262Skato foreach $ar (@{$self->{'protos_todo'}}) { 75842262Skato if (ref $ar->[1]) { 75942262Skato # Only print a constant if it occurs in the same package as a 76042262Skato # dumped sub. This is not perfect, but a heuristic that will 76142262Skato # hopefully work most of the time. Ideally we would use 76242262Skato # CvFILE, but a constant stub has no CvFILE. 76342262Skato my $pack = ($ar->[0] =~ /(.*)::/)[0]; 76442262Skato next if $pack and !$self->{packs}{$pack} 76542262Skato } 76642262Skato my $body = defined $ar->[1] 76742262Skato ? ref $ar->[1] 76842262Skato ? " () {\n " . $self->const($ar->[1]->RV,0) . ";\n}" 76942262Skato : " (". $ar->[1] . ");" 77042262Skato : ";"; 77142262Skato push @ret, "sub " . $ar->[0] . "$body\n"; 77242262Skato } 77342262Skato delete $self->{'protos_todo'}; 77442262Skato return @ret; 77542262Skato} 77642262Skato 77742262Skatosub style_opts { 77842262Skato my $self = shift; 77942262Skato my $opts = shift; 78042262Skato my $opt; 78142262Skato while (length($opt = substr($opts, 0, 1))) { 78242262Skato if ($opt eq "C") { 78342262Skato $self->{'cuddle'} = " "; 78442262Skato $opts = substr($opts, 1); 78542262Skato } elsif ($opt eq "i") { 78642262Skato $opts =~ s/^i(\d+)//; 78742262Skato $self->{'indent_size'} = $1; 78854174Snyan } elsif ($opt eq "T") { 78954174Snyan $self->{'use_tabs'} = 1; 79054174Snyan $opts = substr($opts, 1); 79154174Snyan } elsif ($opt eq "v") { 79254174Snyan $opts =~ s/^v([^.]*)(.|$)//; 79354174Snyan $self->{'ex_const'} = $1; 79454174Snyan } 79554174Snyan } 79660472Snyan} 79760472Snyan 79860472Snyansub new { 79960472Snyan my $class = shift; 80060472Snyan my $self = bless {}, $class; 80160472Snyan $self->{'cuddle'} = "\n"; 80261897Snyan $self->{'curcop'} = undef; 80361897Snyan $self->{'curstash'} = "main"; 80461897Snyan $self->{'ex_const'} = "'???'"; 80561897Snyan $self->{'expand'} = 0; 80660472Snyan $self->{'files'} = {}; 80742262Skato $self->{'packs'} = {}; 80860472Snyan $self->{'indent_size'} = 4; 80960472Snyan $self->{'linenums'} = 0; 81060472Snyan $self->{'parens'} = 0; 81161897Snyan $self->{'subs_todo'} = []; 81261897Snyan $self->{'unquote'} = 0; 81342262Skato $self->{'use_dumper'} = 0; 81442262Skato $self->{'use_tabs'} = 0; 81542262Skato 81661897Snyan $self->{'ambient_warnings'} = undef; # Assume no lexical warnings 81742262Skato $self->{'ambient_hints'} = 0; 81861897Snyan $self->{'ambient_hinthash'} = undef; 81942262Skato $self->init(); 82061897Snyan 82142262Skato while (my $arg = shift @_) { 82261897Snyan if ($arg eq "-d") { 82361897Snyan $self->{'use_dumper'} = 1; 82442262Skato require Data::Dumper; 82561897Snyan } elsif ($arg =~ /^-f(.*)/) { 82661897Snyan $self->{'files'}{$1} = 1; 82742262Skato } elsif ($arg eq "-l") { 82861897Snyan $self->{'linenums'} = 1; 82961897Snyan } elsif ($arg eq "-p") { 83042262Skato $self->{'parens'} = 1; 83161897Snyan } elsif ($arg eq "-P") { 83242262Skato $self->{'noproto'} = 1; 83361897Snyan } elsif ($arg eq "-q") { 83442262Skato $self->{'unquote'} = 1; 83561897Snyan } elsif (substr($arg, 0, 2) eq "-s") { 83642262Skato $self->style_opts(substr $arg, 2); 83761897Snyan } elsif ($arg =~ /^-x(\d)$/) { 83842262Skato $self->{'expand'} = $1; 83942262Skato } 84042262Skato } 84116359Sasami return $self; 84242265Skato} 84342265Skato 84416359Sasami 84542262Skato# Initialise the contextual information, either from 84642262Skato# defaults provided with the ambient_pragmas method, 84742265Skato# or from perl's own defaults otherwise. 84842265Skatosub init { 84942265Skato my $self = shift; 85042265Skato 85142265Skato $self->{'warnings'} = $self->{'ambient_warnings'}; 85242265Skato $self->{'hints'} = $self->{'ambient_hints'}; 85342265Skato $self->{'hinthash'} = $self->{'ambient_hinthash'}; 85442265Skato 85542265Skato # also a convenient place to clear out subs_declared 85616359Sasami delete $self->{'subs_declared'}; 85716359Sasami} 85842265Skato 85942262Skatosub compile { 86016359Sasami my(@args) = @_; 86116359Sasami return sub { 86226439Skato my $self = B::Deparse->new(@args); 86326439Skato # First deparse command-line args 86426439Skato if (defined $^I) { # deparse -i 86526439Skato print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n); 86626439Skato } 86726439Skato if ($^W) { # deparse -w 86826439Skato print qq(BEGIN { \$^W = $^W; }\n); 86926439Skato } 87026439Skato if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0 87126439Skato my $fs = perlstring($/) || 'undef'; 87226439Skato my $bs = perlstring($O::savebackslash) || 'undef'; 87362573Sphk print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n); 87426439Skato } 87526439Skato my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : (); 87626439Skato my @UNITCHECKs = B::unitcheck_av->isa("B::AV") 87726439Skato ? B::unitcheck_av->ARRAY 87826439Skato : (); 87926439Skato my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : (); 88026439Skato my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : (); 88126439Skato my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : (); 88226439Skato my @names = qw(BEGIN UNITCHECK CHECK INIT END); 88326439Skato my @blocks = \(@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs); 88426439Skato while (@names) { 88526439Skato my ($name, $blocks) = (shift @names, shift @blocks); 88626439Skato for my $block (@$blocks) { 88726439Skato $self->todo($block, 0, $name); 88826439Skato } 88926439Skato } 89026439Skato $self->stash_subs(); 89126439Skato local($SIG{"__DIE__"}) = 89257928Skato sub { 89326439Skato if ($self->{'curcop'}) { 89426439Skato my $cop = $self->{'curcop'}; 89526439Skato my($line, $file) = ($cop->line, $cop->file); 89626439Skato print STDERR "While deparsing $file near line $line,\n"; 89726439Skato } 89826439Skato }; 89926439Skato $self->{'curcv'} = main_cv; 90026439Skato $self->{'curcvlex'} = undef; 90126439Skato print $self->print_protos; 90226439Skato @{$self->{'subs_todo'}} = 90326439Skato sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}; 90426439Skato my $root = main_root; 90526439Skato local $B::overlay = {}; 90626439Skato unless (null $root) { 90726439Skato $self->pad_subs($self->{'curcv'}); 90826439Skato # Check for a stub-followed-by-ex-cop, resulting from a program 90926439Skato # consisting solely of sub declarations. For backward-compati- 91026439Skato # bility (and sane output) we don���t want to emit the stub. 91126439Skato # leave 91226439Skato # enter 91326439Skato # stub 91426439Skato # ex-nextstate (or ex-dbstate) 91526439Skato my $kid; 91626439Skato if ( $root->name eq 'leave' 91726439Skato and ($kid = $root->first)->name eq 'enter' 91826439Skato and !null($kid = $kid->sibling) and $kid->name eq 'stub' 91926439Skato and !null($kid = $kid->sibling) and $kid->name eq 'null' 92026439Skato and class($kid) eq 'COP' and null $kid->sibling ) 92126439Skato { 92253373Snyan # ignore 92353373Snyan } else { 92453373Snyan $self->pessimise($root, main_start); 92530772Skato print $self->indent($self->deparse_root($root)), "\n"; 92652831Snyan } 92752831Snyan } 92852831Snyan my @text; 92952831Snyan while (scalar(@{$self->{'subs_todo'}})) { 93054407Skato push @text, $self->next_todo; 93154407Skato } 93273022Snyan print $self->indent(join("", @text)), "\n" if @text; 93373022Snyan 93473022Snyan # Print __DATA__ section, if necessary 93553373Snyan no strict 'refs'; 93673022Snyan my $laststash = defined $self->{'curcop'} 93753373Snyan ? $self->{'curcop'}->stash->NAME : $self->{'curstash'}; 93858888Skato if (defined *{$laststash."::DATA"}{IO}) { 93952831Snyan print $self->keyword("package") . " $laststash;\n" 94016359Sasami unless $laststash eq $self->{'curstash'}; 94152831Snyan print $self->keyword("__DATA__") . "\n"; 94252831Snyan print readline(*{$laststash."::DATA"}); 94352831Snyan } 94416359Sasami } 94558888Skato} 94616359Sasami 94716359Sasamisub coderef2text { 94816359Sasami my $self = shift; 94952831Snyan my $sub = shift; 95016359Sasami croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE"); 95116359Sasami 95216359Sasami $self->init(); 95316359Sasami local $self->{in_coderef2text} = 1; 95416359Sasami return $self->indent($self->deparse_sub(svref_2object($sub))); 95516359Sasami} 95616359Sasami 95753986Snyanmy %strict_bits = do { 95852831Snyan local $^H; 95952831Snyan map +($_ => strict::bits($_)), qw/refs subs vars/ 96016359Sasami}; 96116359Sasami 96268360Snyansub ambient_pragmas { 96316359Sasami my $self = shift; 96452831Snyan my ($hint_bits, $warning_bits, $hinthash) = (0); 96557928Skato 96652831Snyan while (@_ > 1) { 96754407Skato my $name = shift(); 96837138Skato my $val = shift(); 96954407Skato 97068360Snyan if ($name eq 'strict') { 97168360Snyan require strict; 97254407Skato 97354407Skato if ($val eq 'none') { 97454407Skato $hint_bits &= $strict_bits{$_} for qw/refs subs vars/; 97554407Skato next(); 97654407Skato } 97754407Skato 97816359Sasami my @names; 97957928Skato if ($val eq "all") { 98078814Snyan @names = qw/refs subs vars/; 98116359Sasami } 98216359Sasami elsif (ref $val) { 98316359Sasami @names = @$val; 98416359Sasami } 98516359Sasami else { 98643663Skato @names = split' ', $val; 98743663Skato } 98816359Sasami $hint_bits |= $strict_bits{$_} for @names; 98957928Skato } 99053986Snyan 99116359Sasami elsif ($name eq 'integer' 99230772Skato || $name eq 'bytes' 99316359Sasami || $name eq 'utf8') { 99458888Skato require "$name.pm"; 99558888Skato if ($val) { 99658888Skato $hint_bits |= ${$::{"${name}::"}{"hint_bits"}}; 99758888Skato } 99858888Skato else { 99958888Skato $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}}; 100045783Skato } 100158888Skato } 100258888Skato 100385149Snyan elsif ($name eq 're') { 100485149Snyan require re; 100585149Snyan if ($val eq 'none') { 100678814Snyan $hint_bits &= ~re::bits(qw/taint eval/); 100785149Snyan next(); 100878814Snyan } 100978814Snyan 101058888Skato my @names; 101158888Skato if ($val eq 'all') { 101258888Skato @names = qw/taint eval/; 101358888Skato } 101458888Skato elsif (ref $val) { 101558888Skato @names = @$val; 101658888Skato } 101758888Skato else { 101858888Skato @names = split' ',$val; 101958888Skato } 102058888Skato $hint_bits |= re::bits(@names); 102158888Skato } 102258888Skato 102358888Skato elsif ($name eq 'warnings') { 102458888Skato if ($val eq 'none') { 102558888Skato $warning_bits = $warnings::NONE; 102658888Skato next(); 102758888Skato } 102858888Skato 102958888Skato my @names; 103058888Skato if (ref $val) { 103158888Skato @names = @$val; 103258888Skato } 103358888Skato else { 103458888Skato @names = split/\s+/, $val; 103558888Skato } 103658888Skato 103758888Skato $warning_bits = $warnings::NONE if !defined ($warning_bits); 103858888Skato $warning_bits |= warnings::bits(@names); 103958888Skato } 104058888Skato 104158888Skato elsif ($name eq 'warning_bits') { 104258888Skato $warning_bits = $val; 104358888Skato } 104458888Skato 104558888Skato elsif ($name eq 'hint_bits') { 104658888Skato $hint_bits = $val; 104758888Skato } 104858888Skato 104958888Skato elsif ($name eq '%^H') { 105058888Skato $hinthash = $val; 105158888Skato } 105258888Skato 105358888Skato else { 105458888Skato croak "Unknown pragma type: $name"; 105558888Skato } 105658888Skato } 105758888Skato if (@_) { 105858888Skato croak "The ambient_pragmas method expects an even number of args"; 105958888Skato } 106058888Skato 106158888Skato $self->{'ambient_warnings'} = $warning_bits; 106258888Skato $self->{'ambient_hints'} = $hint_bits; 106358888Skato $self->{'ambient_hinthash'} = $hinthash; 106458888Skato} 106558888Skato 106658888Skato# This method is the inner loop, so try to keep it simple 106758888Skatosub deparse { 106858888Skato my $self = shift; 106958888Skato my($op, $cx) = @_; 107058888Skato 107158888Skato Carp::confess("Null op in deparse") if !defined($op) 107258888Skato || class($op) eq "NULL"; 107358888Skato my $meth = "pp_" . $op->name; 107458888Skato return $self->$meth($op, $cx); 107558888Skato} 107658888Skato 107751202Snyansub indent { 107852832Snyan my $self = shift; 107952832Snyan my $txt = shift; 108052832Snyan # \cK also swallows a preceding line break when followed by a 108151202Snyan # semicolon. 108251202Snyan $txt =~ s/\n\cK;//g; 108351202Snyan my @lines = split(/\n/, $txt); 108456325Skato my $leader = ""; 108556325Skato my $level = 0; 108616359Sasami my $line; 108752831Snyan for $line (@lines) { 108852831Snyan my $cmd = substr($line, 0, 1); 108952831Snyan if ($cmd eq "\t" or $cmd eq "\b") { 109052832Snyan $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'}; 109152832Snyan if ($self->{'use_tabs'}) { 109252832Snyan $leader = "\t" x ($level / 8) . " " x ($level % 8); 109352831Snyan } else { 109452831Snyan $leader = " " x $level; 109552831Snyan } 109652832Snyan $line = substr($line, 1); 109752832Snyan } 109852832Snyan if (index($line, "\f") > 0) { 109973022Snyan $line =~ s/\f/\n/; 110052832Snyan } 110158888Skato if (substr($line, 0, 1) eq "\f") { 110252831Snyan $line = substr($line, 1); # no indent 110352831Snyan } else { 110452831Snyan $line = $leader . $line; 110558888Skato } 110645783Skato $line =~ s/\cK;?//g; 110758888Skato } 110816359Sasami return join("\n", @lines); 110953373Snyan} 111016359Sasami 111153373Snyansub pad_subs { 111253373Snyan my ($self, $cv) = @_; 111360472Snyan my $padlist = $cv->PADLIST; 111416359Sasami my @names = $padlist->ARRAYelt(0)->ARRAY; 111516359Sasami my @values = $padlist->ARRAYelt(1)->ARRAY; 111645783Skato my @todo; 111716359Sasami PADENTRY: 111836564Skato for my $ix (0.. $#names) { for $_ ($names[$ix]) { 111936564Skato next if class($_) eq "SPECIAL"; 112016359Sasami my $name = $_->PVX; 112116359Sasami if (defined $name && $name =~ /^&./) { 112254255Skato my $low = $_->COP_SEQ_RANGE_LOW; 112351056Skato my $flags = $_->FLAGS; 112451202Snyan my $outer = $flags & PADNAMEf_OUTER; 112551202Snyan if ($flags & PADNAMEf_OUR) { 112616359Sasami push @todo, [$low, undef, 0, $_] 112716359Sasami # [seq, no cv, not format, padname] 112842262Skato unless $outer; 112916359Sasami next; 113016359Sasami } 113160472Snyan my $protocv = $flags & SVpad_STATE 113260472Snyan ? $values[$ix] 113360472Snyan : $_->PROTOCV; 113460472Snyan if (class ($protocv) ne 'CV') { 113571713Snyan my $flags = $flags; 113660472Snyan my $cv = $cv; 113760472Snyan my $name = $_; 113858888Skato while ($flags & PADNAMEf_OUTER && class ($protocv) ne 'CV') 113951202Snyan { 114060472Snyan $cv = $cv->OUTSIDE; 114160472Snyan next PADENTRY if class($cv) eq 'SPECIAL'; # XXX freed? 114260472Snyan my $padlist = $cv->PADLIST; 114373022Snyan my $ix = $name->PARENT_PAD_INDEX; 114473022Snyan $name = $padlist->NAMES->ARRAYelt($ix); 114561897Snyan $flags = $name->FLAGS; 114661897Snyan $protocv = $flags & SVpad_STATE 114771713Snyan ? $padlist->ARRAYelt(1)->ARRAYelt($ix) 114860472Snyan : $name->PROTOCV; 114960472Snyan } 115071713Snyan } 115171713Snyan my $defined_in_this_sub = ${$protocv->OUTSIDE} == $$cv || do { 115260472Snyan my $other = $protocv->PADLIST; 115351202Snyan $$other && $other->outid == $padlist->id; 115451202Snyan }; 115551202Snyan if ($flags & PADNAMEf_OUTER) { 115651202Snyan next unless $defined_in_this_sub; 115751202Snyan push @todo, [$protocv->OUTSIDE_SEQ, $protocv, 0, $_]; 115857928Skato next; 115960472Snyan } 116060472Snyan my $outseq = $protocv->OUTSIDE_SEQ; 116160472Snyan if ($outseq <= $low) { 116271713Snyan # defined before its name is visible, so it���s gotta be 116371713Snyan # declared and defined at once: my sub foo { ... } 116471713Snyan push @todo, [$low, $protocv, 0, $_]; 116571713Snyan } 116660472Snyan else { 116760472Snyan # declared and defined separately: my sub f; sub f { ... } 116860472Snyan push @todo, [$low, undef, 0, $_]; 116951202Snyan push @todo, [$outseq, $protocv, 0, $_] 117060472Snyan if $defined_in_this_sub; 117160472Snyan } 117260472Snyan } 117360472Snyan }} 117471713Snyan @{$self->{'subs_todo'}} = 117572431Skato sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo 117671713Snyan} 117753373Snyan 117853373Snyan 117953373Snyan# deparse_argops(): deparse, if possible, a sequence of argcheck + argelem 118053373Snyan# ops into a subroutine signature. If successful, return the first op 118153373Snyan# following the signature ops plus the signature string; else return the 118253373Snyan# empty list. 118353373Snyan# 118453373Snyan# Normally a bunch of argelem ops will have been generated by the 118516359Sasami# signature parsing, but it's possible that ops have been added manually 118616359Sasami# or altered. In this case we return "()" and fall back to general 118716359Sasami# deparsing of the individual sigelems as 'my $x = $_[N]' etc. 118816359Sasami# 118916359Sasami# We're only called if the top is an ex-argcheck, which is a placeholder 119016359Sasami# indicating a signature subtree. 119116359Sasami# 119245783Skato# Return a signature string, or an empty list if no deparseable as a 119353373Snyan# signature 119453373Snyan 119553373Snyansub deparse_argops { 119653373Snyan my ($self, $topop, $cv) = @_; 119745783Skato 119845783Skato my @sig; 119916359Sasami 120045783Skato 120145783Skato $topop = $topop->first; 120253373Snyan return unless $$topop and $topop->name eq 'lineseq'; 120353373Snyan 120453373Snyan 120553373Snyan # last op should be nextstate 120660472Snyan my $last = $topop->last; 120760472Snyan return unless $$last 120861897Snyan and ( _op_is_or_was($last, OP_NEXTSTATE) 120951202Snyan or _op_is_or_was($last, OP_DBSTATE)); 121045783Skato 121142262Skato # first OP_NEXTSTATE 121245783Skato 121345783Skato my $o = $topop->first; 121454255Skato return unless $$o; 121554255Skato return if $o->label; 121654255Skato 121753373Snyan # OP_ARGCHECK 121845783Skato 121942262Skato $o = $o->sibling; 122045783Skato return unless $$o and $o->name eq 'argcheck'; 122116359Sasami 122216359Sasami my ($params, $opt_params, $slurpy) = $o->aux_list($cv); 122353373Snyan my $mandatory = $params - $opt_params; 122416359Sasami my $seen_slurpy = 0; 122545783Skato my $last_ix = -1; 122645783Skato 122745783Skato # keep looking for valid nextstate + argelem pairs, terminated 122856793Skato # by a final nextstate 122945783Skato 123032546Skato while (1) { 123132546Skato $o = $o->sibling; 123216359Sasami return unless $$o; 123332691Skato 123442262Skato # skip trailing nextstate 123516359Sasami last if $$o == $$last; 123616359Sasami 123716359Sasami # OP_NEXTSTATE 123859493Snyan return unless $o->name =~ /^(next|db)state$/; 123959493Snyan return if $o->label; 124057928Skato 124159493Snyan # OP_ARGELEM 124242262Skato $o = $o->sibling; 124353884Snyan last unless $$o; 124442262Skato 124516359Sasami if ($o->name eq 'argelem') { 124616359Sasami my $ix = $o->string($cv); 124716359Sasami while (++$last_ix < $ix) { 124816359Sasami push @sig, $last_ix < $mandatory ? '$' : '$='; 124916359Sasami } 125016359Sasami my $var = $self->padname($o->targ); 125116359Sasami if ($var =~ /^[@%]/) { 125216359Sasami return if $seen_slurpy; 125316359Sasami $seen_slurpy = 1; 125416359Sasami return if $ix != $params or !$slurpy 125516359Sasami or substr($var,0,1) ne $slurpy; 125616359Sasami } 125716359Sasami else { 125857928Skato return if $ix >= $params; 125916359Sasami } 126042262Skato if ($o->flags & OPf_KIDS) { 126142262Skato my $kid = $o->first; 126242262Skato return unless $$kid and $kid->name eq 'argdefelem'; 126342262Skato my $def = $self->deparse($kid->first, 7); 126442262Skato $def = "($def)" if $kid->first->flags & OPf_PARENS; 126545830Skato my $assign = "="; 126642262Skato $assign = "//=" if $kid->private & OPpARG_IF_UNDEF; 126742262Skato $assign = "||=" if $kid->private & OPpARG_IF_FALSE; 126842262Skato $var .= " $assign $def"; 126942262Skato } 127042262Skato push @sig, $var; 127142262Skato } 127242262Skato elsif ($o->name eq 'null' 127345830Skato and ($o->flags & OPf_KIDS) 127416359Sasami and $o->first->name eq 'argdefelem') 127516359Sasami { 127645830Skato # special case - a void context default expression: $ = expr 127716359Sasami 127851202Snyan my $defop = $o->first; 127945830Skato my $ix = $defop->targ; 128016359Sasami while (++$last_ix < $ix) { 128116359Sasami push @sig, $last_ix < $mandatory ? '$' : '$='; 128216359Sasami } 128316359Sasami return if $last_ix >= $params 128416359Sasami or $last_ix < $mandatory; 128516359Sasami my $def = $self->deparse($defop->first, 7); 128616359Sasami $def = "($def)" if $defop->first->flags & OPf_PARENS; 128716359Sasami push @sig, '$ = ' . $def; 128816359Sasami } 128916359Sasami else { 129016359Sasami return; 129116359Sasami } 129253373Snyan 129357291Skato } 129460472Snyan 129554255Skato while (++$last_ix < $params) { 129654255Skato push @sig, $last_ix < $mandatory ? '$' : '$='; 129760472Snyan } 129854255Skato push @sig, $slurpy if $slurpy and !$seen_slurpy; 129953373Snyan 130053373Snyan return (join(', ', @sig)); 130153373Snyan} 130253373Snyan 130353373Snyan 130453373Snyan# Deparse a sub. Returns everything except the 'sub foo', 130553373Snyan# e.g. ($$) : method { ...; } 130657291Skato# or : prototype($$) lvalue ($a, $b) { ...; }; 130757291Skato 130857291Skatosub deparse_sub { 130957291Skato my $self = shift; 131057291Skato my $cv = shift; 131157291Skato my @attrs; 131257291Skato my $proto; 131357291Skato my $sig; 131457291Skato 131557291SkatoCarp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL"); 131657291SkatoCarp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); 131753373Snyan local $self->{'curcop'} = $self->{'curcop'}; 131853373Snyan 131953373Snyan my $has_sig = $self->feature_enabled('signatures'); 132053373Snyan if ($cv->FLAGS & SVf_POK) { 132154255Skato my $myproto = $cv->PV; 132253373Snyan if ($has_sig) { 132353373Snyan push @attrs, "prototype($myproto)"; 132453373Snyan } 132553373Snyan else { 132653373Snyan $proto = $myproto; 132742262Skato } 132842262Skato } 132942262Skato if ($cv->CvFLAGS & (CVf_NOWARN_AMBIGUOUS|CVf_LOCKED|CVf_LVALUE|CVf_ANONCONST)) { 133053373Snyan push @attrs, "lvalue" if $cv->CvFLAGS & CVf_LVALUE; 133160472Snyan push @attrs, "method" if $cv->CvFLAGS & CVf_NOWARN_AMBIGUOUS; 133260472Snyan push @attrs, "const" if $cv->CvFLAGS & CVf_ANONCONST; 133360472Snyan } 133459493Snyan 133559493Snyan local($self->{'curcv'}) = $cv; 133659493Snyan local($self->{'curcvlex'}); 133760472Snyan local(@$self{qw'curstash warnings hints hinthash'}) 133860472Snyan = @$self{qw'curstash warnings hints hinthash'}; 133960472Snyan my $body; 134060472Snyan my $root = $cv->ROOT; 134142262Skato local $B::overlay = {}; 134216359Sasami if (not null $root) { 134342262Skato $self->pad_subs($cv); 134442262Skato $self->pessimise($root, $cv->START); 134542262Skato my $lineseq = $root->first; 134660472Snyan 134745783Skato # stub sub may have single op rather than list of ops 134845783Skato my $is_list = ($lineseq->name eq "lineseq"); 134945783Skato my $firstop = $is_list ? $lineseq->first : $lineseq; 135045783Skato 135145783Skato # Try to deparse first subtree as a signature if possible. 135242262Skato # Top of signature subtree has an ex-argcheck as a placeholder 135345783Skato if ( $has_sig 135445783Skato and $$firstop 135559493Snyan and $firstop->name eq 'null' 135659493Snyan and $firstop->targ == OP_ARGCHECK 135742262Skato ) { 135860472Snyan my ($mysig) = $self->deparse_argops($firstop, $cv); 135916359Sasami if (defined $mysig) { 136016359Sasami $sig = $mysig; 136116359Sasami $firstop = $is_list ? $firstop->sibling : undef; 136216359Sasami } 136316359Sasami } 136416359Sasami 136516359Sasami if ($is_list && $firstop) { 136616359Sasami my @ops; 136716359Sasami for (my $o = $firstop; $$o; $o=$o->sibling) { 136872200Sbmilekic push @ops, $o; 136916359Sasami } 137016359Sasami $body = $self->lineseq(undef, 0, @ops).";"; 137116359Sasami if (!$has_sig and $ops[-1]->name =~ /^(next|db)state$/) { 137216359Sasami # this handles void context in 137316359Sasami # use feature signatures; sub ($=1) {} 137416359Sasami $body .= "\n()"; 137516359Sasami } 137616359Sasami my $scope_en = $self->find_scope_en($lineseq); 137716359Sasami if (defined $scope_en) { 137816359Sasami my $subs = join"", $self->seq_subs($scope_en); 137916359Sasami $body .= ";\n$subs" if length($subs); 138016359Sasami } 138124655Skato } 138224655Skato elsif ($firstop) { 138324655Skato $body = $self->deparse($root->first, 0); 138442262Skato } 138542262Skato else { 138642262Skato $body = ';'; # stub sub 138760472Snyan } 138860472Snyan 138960472Snyan my $l = ''; 139060472Snyan if ($self->{'linenums'}) { 139142262Skato # a glob's gp_line is set from the line containing a 139260472Snyan # sub's closing '}' if the CV is the first use of the GV. 139360472Snyan # So make sure the linenum is set correctly for '}' 139460472Snyan my $gv = $cv->GV; 139560472Snyan my $line = $gv->LINE; 139642262Skato my $file = $gv->FILE; 139726439Skato $l = "\f#line $line \"$file\"\n"; 139824655Skato } 139916359Sasami $body = "{\n\t$body\n$l\b}"; 140016359Sasami } 140116359Sasami else { 140216359Sasami my $sv = $cv->const_sv; 140316359Sasami if ($$sv) { 140416359Sasami # uh-oh. inlinable sub... format it differently 140516359Sasami $body = "{ " . $self->const($sv, 0) . " }\n"; 140660472Snyan } else { # XSUB? (or just a declaration) 140760472Snyan $body = ';' 140836564Skato } 140936564Skato } 141016359Sasami $proto = defined $proto ? "($proto) " : ""; 141116359Sasami $sig = defined $sig ? "($sig) " : ""; 141216359Sasami my $attrs = ''; 141316359Sasami $attrs = ': ' . join('', map "$_ ", @attrs) if @attrs; 141416359Sasami return "$proto$attrs$sig$body\n"; 141516359Sasami} 141660472Snyan 141716359Sasamisub deparse_format { 141816359Sasami my $self = shift; 141916359Sasami my $form = shift; 142016359Sasami my @text; 142116359Sasami local($self->{'curcv'}) = $form; 142216359Sasami local($self->{'curcvlex'}); 142316359Sasami local($self->{'in_format'}) = 1; 142416359Sasami local(@$self{qw'curstash warnings hints hinthash'}) 142516359Sasami = @$self{qw'curstash warnings hints hinthash'}; 142660472Snyan my $op = $form->ROOT; 142742262Skato local $B::overlay = {}; 142845783Skato $self->pessimise($op, $form->START); 142960472Snyan my $kid; 143060472Snyan return "\f." if $op->first->name eq 'stub' 143116359Sasami || $op->first->name eq 'nextstate'; 143216359Sasami $op = $op->first->first; # skip leavewrite, lineseq 143316359Sasami while (not null $op) { 143416359Sasami $op = $op->sibling; # skip nextstate 143516359Sasami my @exprs; 143616359Sasami $kid = $op->first->sibling; # skip pushmark 143716359Sasami push @text, "\f".$self->const_sv($kid)->PV; 143860472Snyan $kid = $kid->sibling; 143926439Skato for (; not null $kid; $kid = $kid->sibling) { 144016359Sasami push @exprs, $self->deparse($kid, -1); 144116359Sasami $exprs[-1] =~ s/;\z//; 144216359Sasami } 144316359Sasami push @text, "\f".join(", ", @exprs)."\n" if @exprs; 144416359Sasami $op = $op->sibling; 144516359Sasami } 144616359Sasami return join("", @text) . "\f."; 144716359Sasami} 144816359Sasami 144960472Snyansub is_scope { 145016359Sasami my $op = shift; 145151202Snyan return $op->name eq "leave" || $op->name eq "scope" 145252831Snyan || $op->name eq "lineseq" 145332332Skato || ($op->name eq "null" && class($op) eq "UNOP" 145432332Skato && (is_scope($op->first) || $op->first->name eq "enter")); 145553373Snyan} 145653373Snyan 145753373Snyansub is_state { 145853373Snyan my $name = $_[0]->name; 145960472Snyan return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate"; 146053373Snyan} 146153373Snyan 146253373Snyansub is_miniwhile { # check for one-line loop ('foo() while $y--') 146353373Snyan my $op = shift; 146453373Snyan return (!null($op) and null($op->sibling) 146560472Snyan and $op->name eq "null" and class($op) eq "UNOP" 146660472Snyan and (($op->first->name =~ /^(and|or)$/ 146753373Snyan and $op->first->first->sibling->name eq "lineseq") 146853373Snyan or ($op->first->name eq "lineseq" 146953373Snyan and not null $op->first->first->sibling 147053373Snyan and $op->first->first->sibling->name eq "unstack") 147153373Snyan )); 147283539Snyan} 147353373Snyan 147432332Skato# Check if the op and its sibling are the initialization and the rest of a 147553373Snyan# for (..;..;..) { ... } loop 147653373Snyansub is_for_loop { 147732332Skato my $op = shift; 147883539Snyan # This OP might be almost anything, though it won't be a 147960472Snyan # nextstate. (It's the initialization, so in the canonical case it 148072200Sbmilekic # will be an sassign.) The sibling is (old style) a lineseq whose 148153373Snyan # first child is a nextstate and whose second is a leaveloop, or 148253373Snyan # (new style) an unstack whose sibling is a leaveloop. 148352831Snyan my $lseq = $op->sibling; 148453373Snyan return 0 unless !is_state($op) and !null($lseq); 148516359Sasami if ($lseq->name eq "lineseq") { 148616359Sasami if ($lseq->first && !null($lseq->first) && is_state($lseq->first) 148716359Sasami && (my $sib = $lseq->first->sibling)) { 148816359Sasami return (!null($sib) && $sib->name eq "leaveloop"); 148916359Sasami } 149016359Sasami } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) { 149116359Sasami my $sib = $lseq->sibling; 149216359Sasami return $sib && !null($sib) && $sib->name eq "leaveloop"; 149316359Sasami } 149460472Snyan return 0; 149560472Snyan} 149660472Snyan 149717256Sasamisub is_scalar { 149836564Skato my $op = shift; 149960472Snyan return ($op->name eq "rv2sv" or 150042262Skato $op->name eq "padsv" or 150145783Skato $op->name eq "gv" or # only in array/hash constructs 150260472Snyan $op->flags & OPf_KIDS && !null($op->first) 150342262Skato && $op->first->name eq "gvsv"); 150416359Sasami} 150536564Skato 150660472Snyansub maybe_parens { 150742262Skato my $self = shift; 150845783Skato my($text, $cx, $prec) = @_; 150960472Snyan if ($prec < $cx # unary ops nest just fine 151042262Skato or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21 151116359Sasami or $self->{'parens'}) 151216359Sasami { 151316359Sasami $text = "($text)"; 151416359Sasami # In a unop, let parent reuse our parens; see maybe_parens_unop 151516359Sasami $text = "\cS" . $text if $cx == 16; 151616359Sasami return $text; 151745816Skato } else { 151816359Sasami return $text; 151916359Sasami } 152016359Sasami} 152160472Snyan 152260472Snyan# same as above, but get around the 'if it looks like a function' rule 152360472Snyansub maybe_parens_unop { 152442262Skato my $self = shift; 152545783Skato my($name, $kid, $cx) = @_; 152660472Snyan if ($cx > 16 or $self->{'parens'}) { 152742262Skato $kid = $self->deparse($kid, 1); 152816359Sasami if ($name eq "umask" && $kid =~ /^\d+$/) { 152936564Skato $kid = sprintf("%#o", $kid); 153060472Snyan } 153142262Skato return $self->keyword($name) . "($kid)"; 153242262Skato } else { 153360472Snyan $kid = $self->deparse($kid, 16); 153460472Snyan if ($name eq "umask" && $kid =~ /^\d+$/) { 153542262Skato $kid = sprintf("%#o", $kid); 153642262Skato } 153716359Sasami $name = $self->keyword($name); 153872200Sbmilekic if (substr($kid, 0, 1) eq "\cS") { 153916359Sasami # use kid's parens 154036662Skato return $name . substr($kid, 1); 154154255Skato } elsif (substr($kid, 0, 1) eq "(") { 154254255Skato # avoid looks-like-a-function trap with extra parens 154336564Skato # ('+' can lead to ambiguities) 154454255Skato return "$name(" . $kid . ")"; 154553373Snyan } else { 154636564Skato return "$name $kid"; 154736662Skato } 154845783Skato } 154945783Skato} 155036564Skato 155145783Skatosub maybe_parens_func { 155216359Sasami my $self = shift; 155316359Sasami my($func, $text, $cx, $prec) = @_; 155460472Snyan if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) { 155545783Skato return "$func($text)"; 155636564Skato } else { 155736564Skato return $func . (length($text) ? " $text" : ""); 155845783Skato } 155936564Skato} 156036564Skato 156136564Skatosub find_our_type { 156236564Skato my ($self, $name) = @_; 156336564Skato $self->populate_curcvlex() if !defined $self->{'curcvlex'}; 156436564Skato my $seq = $self->{'curcop'} ? $self->{'curcop'}->cop_seq : 0; 156516359Sasami for my $a (@{$self->{'curcvlex'}{"o$name"}}) { 156651202Snyan my ($st, undef, $padname) = @$a; 156745783Skato if ($st >= $seq && $padname->FLAGS & PADNAMEf_TYPED) { 156816359Sasami return $padname->SvSTASH->NAME; 156916359Sasami } 157016359Sasami } 157116359Sasami return ''; 157246871Skato} 157316359Sasami 157416359Sasamisub maybe_local { 157516359Sasami my $self = shift; 157616359Sasami my($op, $cx, $text) = @_; 157716359Sasami my $name = $op->name; 157816359Sasami my $our_intro = ($name =~ /^(?:(?:gv|rv2)[ash]v|split|refassign 157916359Sasami |lv(?:av)?ref)$/x) 158016359Sasami ? OPpOUR_INTRO 158116359Sasami : 0; 158216359Sasami my $lval_intro = $name eq 'split' ? 0 : OPpLVAL_INTRO; 158316359Sasami # The @a in \(@a) isn't in ref context, but only when the 158416359Sasami # parens are there. 158516359Sasami my $need_parens = $self->{'in_refgen'} && $name =~ /[ah]v\z/ 158616359Sasami && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS; 158716359Sasami if ((my $priv = $op->private) & ($lval_intro|$our_intro)) { 158816359Sasami my @our_local; 158916359Sasami push @our_local, "local" if $priv & $lval_intro; 159016359Sasami push @our_local, "our" if $priv & $our_intro; 159116359Sasami my $our_local = join " ", map $self->keyword($_), @our_local; 159216359Sasami if( $our_local[-1] eq 'our' ) { 159316359Sasami if ( $text !~ /^\W(\w+::)*\w+\z/ 159442265Skato and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/ 159542265Skato ) { 159642265Skato die "Unexpected our($text)\n"; 159742265Skato } 159816359Sasami $text =~ s/(\w+::)+//; 159916359Sasami 160042265Skato if (my $type = $self->find_our_type($text)) { 160116359Sasami $our_local .= ' ' . $type; 160216359Sasami } 160316359Sasami } 160416359Sasami return $need_parens ? "($text)" : $text 160542262Skato if $self->{'avoid_local'}{$$op}; 160660472Snyan if ($need_parens) { 160760472Snyan return "$our_local($text)"; 160842262Skato } elsif (want_scalar($op) || $our_local eq 'our') { 160960472Snyan return "$our_local $text"; 161042262Skato } else { 161116359Sasami return $self->maybe_parens_func("$our_local", $text, $cx, 16); 161216359Sasami } 161316359Sasami } else { 161416359Sasami return $need_parens ? "($text)" : $text; 161516359Sasami } 161616359Sasami} 161716359Sasami 161816359Sasamisub maybe_targmy { 161916359Sasami my $self = shift; 162042265Skato my($op, $cx, $func, @args) = @_; 162142265Skato if ($op->private & OPpTARGET_MY) { 162242265Skato my $var = $self->padname($op->targ); 162342265Skato my $val = $func->($self, $op, 7, @args); 162442265Skato return $self->maybe_parens("$var = $val", $cx, 7); 162516359Sasami } else { 162616359Sasami return $func->($self, $op, $cx, @args); 162716359Sasami } 162842265Skato} 162916359Sasami 163016359Sasamisub padname_sv { 163116359Sasami my $self = shift; 163216359Sasami my $targ = shift; 163316359Sasami return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ); 163416359Sasami} 163516359Sasami 163616359Sasamisub maybe_my { 163716359Sasami my $self = shift; 163816359Sasami my($op, $cx, $text, $padname, $forbid_parens) = @_; 163916359Sasami # The @a in \(@a) isn't in ref context, but only when the 164016359Sasami # parens are there. 164116359Sasami my $need_parens = !$forbid_parens && $self->{'in_refgen'} 164216359Sasami && $op->name =~ /[ah]v\z/ 164316359Sasami && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS; 164416359Sasami # The @a in \my @a must not have parens. 164516359Sasami if (!$need_parens && $self->{'in_refgen'}) { 164616359Sasami $forbid_parens = 1; 164716359Sasami } 164816359Sasami if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { 164916359Sasami # Check $padname->FLAGS for statehood, rather than $op->private, 165016359Sasami # because enteriter ops do not carry the flag. 165116359Sasami my $my = 165252831Snyan $self->keyword($padname->FLAGS & SVpad_STATE ? "state" : "my"); 165352831Snyan if ($padname->FLAGS & PADNAMEf_TYPED) { 165452831Snyan $my .= ' ' . $padname->SvSTASH->NAME; 165558888Skato } 165652831Snyan if ($need_parens) { 165752831Snyan return "$my($text)"; 165852831Snyan } elsif ($forbid_parens || want_scalar($op)) { 165958888Skato return "$my $text"; 166045783Skato } else { 166158888Skato return $self->maybe_parens_func($my, $text, $cx, 16); 166216359Sasami } 166316359Sasami } else { 166416359Sasami return $need_parens ? "($text)" : $text; 166516359Sasami } 166616359Sasami} 166716359Sasami 166816359Sasami# The following OPs don't have functions: 166953373Snyan 167051202Snyan# pp_padany -- does not exist after parsing 167151202Snyan 167253373Snyansub AUTOLOAD { 167342262Skato if ($AUTOLOAD =~ s/^.*::pp_//) { 167445783Skato warn "unexpected OP_". 167543663Skato ($_[1]->type == OP_CUSTOM ? "CUSTOM ($AUTOLOAD)" : uc $AUTOLOAD); 167660472Snyan return "XXX"; 167742262Skato } else { 167816359Sasami die "Undefined subroutine $AUTOLOAD called"; 167958888Skato } 168042262Skato} 168160472Snyan 168260472Snyansub DESTROY {} # Do not AUTOLOAD 168360472Snyan 168473022Snyan# $root should be the op which represents the root of whatever 168573022Snyan# we're sequencing here. If it's undefined, then we don't append 168661897Snyan# any subroutine declarations to the deparsed ops, otherwise we 168761897Snyan# append appropriate declarations. 168871713Snyansub lineseq { 168960472Snyan my($self, $root, $cx, @ops) = @_; 169060472Snyan my($expr, @exprs); 169171713Snyan 169271713Snyan my $out_cop = $self->{'curcop'}; 169360472Snyan my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef; 169451202Snyan my $limit_seq; 169551202Snyan if (defined $root) { 169651202Snyan $limit_seq = $out_seq; 169751202Snyan my $nseq; 169851202Snyan $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling}; 169957928Skato $limit_seq = $nseq if !defined($limit_seq) 170060472Snyan or defined($nseq) && $nseq < $limit_seq; 170160472Snyan } 170260472Snyan $limit_seq = $self->{'limit_seq'} 170371713Snyan if defined($self->{'limit_seq'}) 170471713Snyan && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq); 170571713Snyan local $self->{'limit_seq'} = $limit_seq; 170671713Snyan 170760472Snyan $self->walk_lineseq($root, \@ops, 170860472Snyan sub { push @exprs, $_[0]} ); 170960472Snyan 171051202Snyan my $sep = $cx ? '; ' : ";\n"; 171151202Snyan my $body = join($sep, grep {length} @exprs); 171245783Skato my $subs = ""; 171345783Skato if (defined $root && defined $limit_seq && !$self->{'in_format'}) { 171453373Snyan $subs = join "\n", $self->seq_subs($limit_seq); 171553373Snyan } 171653373Snyan return join($sep, grep {length} $body, $subs); 171753373Snyan} 171853373Snyan 171945783Skatosub scopeop { 172043663Skato my($real_block, $self, $op, $cx) = @_; 172160472Snyan my $kid; 172243663Skato my @kids; 172359493Snyan 172459493Snyan local(@$self{qw'curstash warnings hints hinthash'}) 172556512Skato = @$self{qw'curstash warnings hints hinthash'} if $real_block; 172659493Snyan if ($real_block) { 172745783Skato $kid = $op->first->sibling; # skip enter 172842262Skato if (is_miniwhile($kid)) { 172916359Sasami my $top = $kid->first; 173016359Sasami my $name = $top->name; 173116359Sasami if ($name eq "and") { 173216359Sasami $name = $self->keyword("while"); 173316359Sasami } elsif ($name eq "or") { 173416359Sasami $name = $self->keyword("until"); 173516359Sasami } else { # no conditional -> while 1 or until 0 173616359Sasami return $self->deparse($top->first, 1) . " " 173716359Sasami . $self->keyword("while") . " 1"; 173816359Sasami } 173916359Sasami my $cond = $top->first; 174016359Sasami my $body = $cond->sibling->first; # skip lineseq 174116359Sasami $cond = $self->deparse($cond, 1); 174216359Sasami $body = $self->deparse($body, 1); 174316359Sasami return "$body $name $cond"; 174451202Snyan } 174560472Snyan elsif($kid->type == OP_PUSHDEFER && 174660472Snyan $kid->private & OPpDEFER_FINALLY && 174716359Sasami $kid->sibling->type == OP_LEAVETRYCATCH && 174816359Sasami null($kid->sibling->sibling)) { 174945783Skato return $self->pp_leavetrycatch_with_finally($kid->sibling, $kid, $cx); 175057291Skato } 175116359Sasami } else { 175260472Snyan $kid = $op->first; 175360472Snyan } 175460472Snyan for (; !null($kid); $kid = $kid->sibling) { 175560472Snyan push @kids, $kid; 175660472Snyan } 175716359Sasami if ($cx > 0) { # inside an expression, (a do {} while for lineseq) 175816359Sasami my $body = $self->lineseq($op, 0, @kids); 175916359Sasami return is_lexical_subs(@kids) 176016359Sasami ? $body 176160472Snyan : ($self->lex_in_scope("&do") ? "CORE::do" : "do") 176254174Snyan . " {\n\t$body\n\b}"; 176360472Snyan } else { 176460472Snyan my $lineseq = $self->lineseq($op, $cx, @kids); 176554174Snyan return (length ($lineseq) ? "$lineseq;" : ""); 176660472Snyan } 176760472Snyan} 176860472Snyan 176960472Snyansub pp_scope { scopeop(0, @_); } 177060472Snyansub pp_lineseq { scopeop(0, @_); } 177161897Snyansub pp_leave { scopeop(1, @_); } 177260472Snyan 177360472Snyan# This is a special case of scopeop and lineseq, for the case of the 177460472Snyan# main_root. The difference is that we print the output statements as 177560472Snyan# soon as we get them, for the sake of impatient users. 177642262Skatosub deparse_root { 177760472Snyan my $self = shift; 177860472Snyan my($op) = @_; 177960472Snyan local(@$self{qw'curstash warnings hints hinthash'}) 178042262Skato = @$self{qw'curstash warnings hints hinthash'}; 178116359Sasami my @kids; 178216359Sasami return if null $op->first; # Can happen, e.g., for Bytecode without -k 178316359Sasami for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) { 178416359Sasami push @kids, $kid; 178516359Sasami } 178616359Sasami $self->walk_lineseq($op, \@kids, 178716359Sasami sub { return unless length $_[0]; 178832332Skato print $self->indent($_[0].';'); 178916359Sasami print "\n" 179016359Sasami unless $_[1] == $#kids; 179116359Sasami }); 179216359Sasami} 179316359Sasami 179416359Sasamisub walk_lineseq { 179516359Sasami my ($self, $op, $kids, $callback) = @_; 179616359Sasami my @kids = @$kids; 179716359Sasami for (my $i = 0; $i < @kids; $i++) { 179816359Sasami my $expr = ""; 179916359Sasami if (is_state $kids[$i]) { 180016359Sasami $expr = $self->deparse($kids[$i++], 0); 180116359Sasami if ($i > $#kids) { 180216359Sasami $callback->($expr, $i); 180342262Skato last; 180416359Sasami } 180516359Sasami } 180616359Sasami if (is_for_loop($kids[$i])) { 180716359Sasami $callback->($expr . $self->for_loop($kids[$i], 0), 180816359Sasami $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1); 180916359Sasami next; 181016359Sasami } 181126439Skato my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2); 181226439Skato $expr2 =~ s/^sub :(?!:)/+sub :/; # statement label otherwise 181320129Sasami $expr .= $expr2; 181419326Sasami $callback->($expr, $i); 181520129Sasami } 181643663Skato} 181772200Sbmilekic 181856793Skato# The BEGIN {} is used here because otherwise this code isn't executed 181956793Skato# when you run B::Deparse on itself. 182056793Skatomy %globalnames; 182156793SkatoBEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC", 182256793Skato "ENV", "ARGV", "ARGVOUT", "_"); } 182356793Skato 182456793Skatosub gv_name { 182543663Skato my $self = shift; 182672200Sbmilekic my $gv = shift; 182716359Sasami my $raw = shift; 182816359Sasami#Carp::confess() unless ref($gv) eq "B::GV"; 182916359Sasami my $cv = $gv->FLAGS & SVf_ROK ? $gv->RV : 0; 183016359Sasami my $stash = ($cv || $gv)->STASH->NAME; 183116359Sasami my $name = $raw 183216359Sasami ? $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME 183316359Sasami : $cv 183416359Sasami ? B::safename($cv->NAME_HEK || $cv->GV->NAME) 183516359Sasami : $gv->SAFENAME; 183645783Skato if ($stash eq 'main' && $name =~ /^::/) { 183732332Skato $stash = '::'; 183845783Skato } 183916359Sasami elsif (($stash eq 'main' 184016359Sasami && ($globalnames{$name} || $name =~ /^[^A-Za-z_:]/)) 184116359Sasami or ($stash eq $self->{'curstash'} && !$globalnames{$name} 184216359Sasami && ($stash eq 'main' || $name !~ /::/)) 184316359Sasami ) 184416359Sasami { 184560472Snyan $stash = ""; 184660472Snyan } else { 184760472Snyan $stash = $stash . "::"; 184860472Snyan } 184960472Snyan if (!$raw and $name =~ /^(\^..|{)/) { 185060472Snyan $name = "{$name}"; # ${^WARNING_BITS}, etc and ${ 185116359Sasami } 185216359Sasami return $stash . $name; 185316359Sasami} 185416359Sasami 185516359Sasami# Return the name to use for a stash variable. 185616359Sasami# If a lexical with the same name is in scope, or 185716359Sasami# if strictures are enabled, it may need to be 185842262Skato# fully-qualified. 185954174Snyansub stash_variable { 186054174Snyan my ($self, $prefix, $name, $cx) = @_; 186142262Skato 186242262Skato return $prefix.$self->maybe_qualify($prefix, $name) if $name =~ /::/; 186342262Skato 186442262Skato unless ($prefix eq '$' || $prefix eq '@' || $prefix eq '&' || #' 186554174Snyan $prefix eq '%' || $prefix eq '$#') { 186654174Snyan return "$prefix$name"; 186754174Snyan } 186854174Snyan 186954174Snyan if ($name =~ /^[^[:alpha:]_+-]$/) { 187054174Snyan if (defined $cx && $cx == 26) { 187154174Snyan if ($prefix eq '@') { 187254174Snyan return "$prefix\{$name}"; 187354174Snyan } 187416359Sasami elsif ($name eq '#') { return '${#}' } # "${#}a" vs "$#a" 187516359Sasami } 187660472Snyan if ($prefix eq '$#') { 187716359Sasami return "\$#{$name}"; 187827479Skato } 187916359Sasami } 188016359Sasami 188116359Sasami return $prefix . $self->maybe_qualify($prefix, $name); 188216359Sasami} 188316359Sasami 188416359Sasamimy %unctrl = # portable to EBCDIC 188516359Sasami ( 188616359Sasami "\c@" => '@', # unused 188716359Sasami "\cA" => 'A', 188816359Sasami "\cB" => 'B', 188916359Sasami "\cC" => 'C', 189045783Skato "\cD" => 'D', 189125924Skato "\cE" => 'E', 189216359Sasami "\cF" => 'F', 189316359Sasami "\cG" => 'G', 189442262Skato "\cH" => 'H', 189542262Skato "\cI" => 'I', 189642262Skato "\cJ" => 'J', 189742262Skato "\cK" => 'K', 189845783Skato "\cL" => 'L', 189927479Skato "\cM" => 'M', 190027479Skato "\cN" => 'N', 190127479Skato "\cO" => 'O', 190227479Skato "\cP" => 'P', 190345783Skato "\cQ" => 'Q', 190427479Skato "\cR" => 'R', 190527479Skato "\cS" => 'S', 190642262Skato "\cT" => 'T', 190726381Skato "\cU" => 'U', 190842262Skato "\cV" => 'V', 190942262Skato "\cW" => 'W', 191042262Skato "\cX" => 'X', 191160472Snyan "\cY" => 'Y', 191242262Skato "\cZ" => 'Z', 191342262Skato "\c[" => '[', # unused 191442262Skato "\c\\" => '\\', # unused 191542262Skato "\c]" => ']', # unused 191642262Skato "\c_" => '_', # unused 191726381Skato ); 191842262Skato 191942262Skato# Return just the name, without the prefix. It may be returned as a quoted 192042262Skato# string. The second return value is a boolean indicating that. 192126381Skatosub stash_variable_name { 192246871Skato my($self, $prefix, $gv) = @_; 192326381Skato my $name = $self->gv_name($gv, 1); 192426381Skato $name = $self->maybe_qualify($prefix,$name); 192525924Skato if ($name =~ /^(?:\S|(?!\d)[\ca-\cz]?(?:\w|::)*|\d+)\z/) { 192616359Sasami $name =~ s/^([\ca-\cz])/'^' . $unctrl{$1}/e; 192727479Skato $name =~ /^(\^..|{)/ and $name = "{$name}"; 192827479Skato return $name, 0; # not quoted 192927479Skato } 193027479Skato else { 193127479Skato single_delim("q", "'", $name, $self), 1; 193227479Skato } 193327479Skato} 193427479Skato 193516359Sasamisub maybe_qualify { 193616359Sasami my ($self,$prefix,$name) = @_; 193726381Skato my $v = ($prefix eq '$#' ? '@' : $prefix) . $name; 193842262Skato if ($prefix eq "") { 193942262Skato $name .= "::" if $name =~ /(?:\ACORE::[^:]*|::)\z/; 194042262Skato return $name; 194142262Skato } 194260472Snyan return $name if $name =~ /::/; 194360472Snyan return $self->{'curstash'}.'::'. $name 194460472Snyan if 194560472Snyan $name =~ /^(?!\d)\w/ # alphabetic 194642262Skato && $v !~ /^\$[ab]\z/ # not $a or $b 194742262Skato && $v =~ /\A[\$\@\%\&]/ # scalar, array, hash, or sub 194842262Skato && !$globalnames{$name} # not a global name 194916359Sasami && $self->{hints} & $strict_bits{vars} # strict vars 195016359Sasami && !$self->lex_in_scope($v,1) # no "our" 195122120Skato or $self->lex_in_scope($v); # conflicts with "my" variable 195222120Skato return $name; 195322120Skato} 195422120Skato 195522120Skatosub lex_in_scope { 195622120Skato my ($self, $name, $our) = @_; 195722120Skato substr $name, 0, 0, = $our ? 'o' : 'm'; # our/my 195842265Skato $self->populate_curcvlex() if !defined $self->{'curcvlex'}; 195942265Skato 196042265Skato return 0 if !defined($self->{'curcop'}); 196142265Skato my $seq = $self->{'curcop'}->cop_seq; 196216359Sasami return 0 if !exists $self->{'curcvlex'}{$name}; 196322120Skato for my $a (@{$self->{'curcvlex'}{$name}}) { 196442265Skato my ($st, $en) = @$a; 196516359Sasami return 1 if $seq > $st && $seq <= $en; 196616359Sasami } 196742265Skato return 0; 196842265Skato} 196942265Skato 197042265Skatosub populate_curcvlex { 197142265Skato my $self = shift; 197216359Sasami for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) { 197316359Sasami my $padlist = $cv->PADLIST; 197416359Sasami # an undef CV still in lexical chain 197542265Skato next if class($padlist) eq "SPECIAL"; 197616359Sasami my @padlist = $padlist->ARRAY; 197716359Sasami my @ns = $padlist[0]->ARRAY; 197842265Skato 197942265Skato for (my $i=0; $i<@ns; ++$i) { 198042265Skato next if class($ns[$i]) eq "SPECIAL"; 198142265Skato if (class($ns[$i]) eq "PV") { 198242265Skato # Probably that pesky lexical @_ 198342265Skato next; 198442265Skato } 198516359Sasami my $name = $ns[$i]->PVX; 198616359Sasami next unless defined $name; 198716359Sasami my ($seq_st, $seq_en) = 198816359Sasami ($ns[$i]->FLAGS & SVf_FAKE) 198916359Sasami ? (0, 999999) 199042265Skato : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH); 199142265Skato 199242262Skato push @{$self->{'curcvlex'}{ 199342262Skato ($ns[$i]->FLAGS & PADNAMEf_OUR ? 'o' : 'm') . $name 199442265Skato }}, [$seq_st, $seq_en, $ns[$i]]; 199542265Skato } 199642262Skato } 199716359Sasami} 199816359Sasami 199960472Snyansub find_scope_st { ((find_scope(@_))[0]); } 200042262Skatosub find_scope_en { ((find_scope(@_))[1]); } 200142262Skato 200242262Skato# Recurses down the tree, looking for pad variable introductions and COPs 200343338Skatosub find_scope { 200442262Skato my ($self, $op, $scope_st, $scope_en) = @_; 200516359Sasami carp("Undefined op in find_scope") if !defined $op; 200616359Sasami return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS; 200745783Skato 200853373Snyan my @queue = ($op); 200953373Snyan while(my $op = shift @queue ) { 201016359Sasami for (my $o=$op->first; $$o; $o=$o->sibling) { 201116359Sasami if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) { 201245783Skato my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW); 201316359Sasami my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH; 201416359Sasami $scope_st = $s if !defined($scope_st) || $s < $scope_st; 201557291Skato $scope_en = $e if !defined($scope_en) || $e > $scope_en; 201657291Skato return ($scope_st, $scope_en); 201757291Skato } 201857291Skato elsif (is_state($o)) { 201943663Skato my $c = $o->cop_seq; 202016359Sasami $scope_st = $c if !defined($scope_st) || $c < $scope_st; 202116359Sasami $scope_en = $c if !defined($scope_en) || $c > $scope_en; 202216359Sasami return ($scope_st, $scope_en); 202316359Sasami } 202426439Skato elsif ($o->flags & OPf_KIDS) { 202526439Skato unshift (@queue, $o); 202653373Snyan } 202732332Skato } 202816359Sasami } 202916359Sasami 203067551Sjhb return ($scope_st, $scope_en); 203172431Skato} 203272431Skato 203372431Skato# Returns a list of subs which should be inserted before the COP 203472431Skatosub cop_subs { 203538603Skato my ($self, $op, $out_seq) = @_; 203668360Snyan my $seq = $op->cop_seq; 203751202Snyan $seq = $out_seq if defined($out_seq) && $out_seq < $seq; 203868360Snyan return $self->seq_subs($seq); 203951202Snyan} 204068360Snyan 204151202Snyansub seq_subs { 204268360Snyan my ($self, $seq) = @_; 204351202Snyan my @text; 204468360Snyan#push @text, "# ($seq)\n"; 204568360Snyan 204651202Snyan return "" if !defined $seq; 204768360Snyan my @pending; 204868360Snyan while (scalar(@{$self->{'subs_todo'}}) 204951202Snyan and $seq > $self->{'subs_todo'}[0][0]) { 205051202Snyan my $cv = $self->{'subs_todo'}[0][1]; 205145226Skato # Skip the OUTSIDE check for lexical subs. We may be deparsing a 205245226Skato # cloned anon sub with lexical subs declared in it, in which case 205345783Skato # the OUTSIDE pointer points to the anon protosub. 205451202Snyan my $lexical = ref $self->{'subs_todo'}[0][3]; 205551202Snyan my $outside = !$lexical && $cv && $cv->OUTSIDE; 205653373Snyan if (!$lexical and $cv 205753373Snyan and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}}) 205853373Snyan { 205965568Skato push @pending, shift @{$self->{'subs_todo'}}; 206054407Skato next; 206154255Skato } 206254255Skato push @text, $self->next_todo; 206354255Skato } 206454407Skato unshift @{$self->{'subs_todo'}}, @pending; 206554255Skato return @text; 206683539Snyan} 206754255Skato 206853373Snyansub _features_from_bundle { 206953373Snyan my ($hints, $hh) = @_; 207083539Snyan foreach (@{$feature::feature_bundle{@feature::hint_bundles[$hints >> $feature::hint_shift]}}) { 207183539Snyan $hh->{$feature::feature{$_}} = 1; 207283539Snyan } 207383539Snyan return $hh; 207483539Snyan} 207583539Snyan 207683539Snyan# generate any pragmas, 'package foo' etc needed to synchronise 207783539Snyan# with the given cop 207883539Snyan 207983539Snyansub pragmata { 208053373Snyan my $self = shift; 208145783Skato my($op) = @_; 208245783Skato 208316359Sasami my @text; 208416359Sasami 208516359Sasami my $stash = $op->stashpv; 208683434Simp if ($stash ne $self->{'curstash'}) { 208716359Sasami push @text, $self->keyword("package") . " $stash;\n"; 208816359Sasami $self->{'curstash'} = $stash; 208916359Sasami } 209083434Simp 209116359Sasami my $warnings = $op->warnings; 209216359Sasami my $warning_bits; 209316359Sasami if ($warnings->isa("B::SPECIAL") && $$warnings == 4) { 209416359Sasami $warning_bits = $warnings::Bits{"all"}; 209516359Sasami } 209616359Sasami elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) { 209716359Sasami $warning_bits = $warnings::NONE; 209816359Sasami } 209916359Sasami elsif ($warnings->isa("B::SPECIAL")) { 210016359Sasami $warning_bits = undef; 210153373Snyan } 210253373Snyan else { 210316359Sasami $warning_bits = $warnings->PV; 210416359Sasami } 210516359Sasami 210616359Sasami my ($w1, $w2); 210716359Sasami # The number of valid bit positions may have grown (by a byte or 210851202Snyan # more) since the last warnings state, by custom warnings 210916359Sasami # categories being registered in the meantime. Normalise the 211016359Sasami # bitmasks first so they may be fairly compared. 211116359Sasami $w1 = defined($self->{warnings}) 211216359Sasami ? warnings::_expand_bits($self->{warnings}) 211316359Sasami : undef; 211416359Sasami $w2 = defined($warning_bits) 211516359Sasami ? warnings::_expand_bits($warning_bits) 211616359Sasami : undef; 211716359Sasami 211816359Sasami if (defined($w2) and !defined($w1) || $w1 ne $w2) { 211916359Sasami push @text, $self->declare_warnings($w1, $w2); 212016359Sasami $self->{'warnings'} = $w2; 212116359Sasami } 212216359Sasami 212316359Sasami my $hints = $op->hints; 212416359Sasami my $old_hints = $self->{'hints'}; 212516359Sasami if ($self->{'hints'} != $hints) { 212616359Sasami push @text, $self->declare_hints($self->{'hints'}, $hints); 212716359Sasami $self->{'hints'} = $hints; 212816359Sasami } 212916359Sasami 213016359Sasami my $newhh; 213116359Sasami $newhh = $op->hints_hash->HASH; 213216359Sasami 213316359Sasami { 213416359Sasami # feature bundle hints 213516359Sasami my $from = $old_hints & $feature::hint_mask; 213616359Sasami my $to = $ hints & $feature::hint_mask; 213716359Sasami if ($from != $to) { 213816359Sasami if ($to == $feature::hint_mask) { 213916359Sasami if ($self->{'hinthash'}) { 214016359Sasami delete $self->{'hinthash'}{$_} 214116359Sasami for grep /^feature_/, keys %{$self->{'hinthash'}}; 214216359Sasami } 214316359Sasami else { $self->{'hinthash'} = {} } 214416359Sasami $self->{'hinthash'} 214516359Sasami = _features_from_bundle($from, $self->{'hinthash'}); 214616359Sasami } 214743425Sphk else { 214883434Simp my $bundle = 214916359Sasami $feature::hint_bundles[$to >> $feature::hint_shift]; 215016359Sasami $bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12 215116359Sasami push @text, 215216359Sasami $self->keyword("no") . " feature ':all';\n", 215316359Sasami $self->keyword("use") . " feature ':$bundle';\n"; 215416359Sasami } 215516359Sasami } 215616359Sasami } 215716359Sasami 215816359Sasami { 215916359Sasami push @text, $self->declare_hinthash( 216052831Snyan $self->{'hinthash'}, $newhh, 216151654Sphk $self->{indent_size}, $self->{hints}, 216216359Sasami ); 216316359Sasami $self->{'hinthash'} = $newhh; 216416359Sasami } 216516359Sasami 216642262Skato return join("", @text); 216716359Sasami} 216816359Sasami 216916359Sasami 217016359Sasami# Notice how subs and formats are inserted between statements here; 217116359Sasami# also $[ assignments and pragmas. 217216359Sasamisub pp_nextstate { 217316359Sasami my $self = shift; 217416359Sasami my($op, $cx) = @_; 217516359Sasami $self->{'curcop'} = $op; 217616359Sasami 217742262Skato my @text; 217816359Sasami 217916359Sasami my @subs = $self->cop_subs($op); 218054174Snyan if (@subs) { 218154174Snyan # Special marker to swallow up the semicolon 218254174Snyan push @subs, "\cK"; 218354174Snyan } 218454174Snyan push @text, @subs; 218516359Sasami 218616359Sasami push @text, $self->pragmata($op); 218716359Sasami 218816359Sasami 218916359Sasami # This should go after of any branches that add statements, to 219016359Sasami # increase the chances that it refers to the same line it did in 219116359Sasami # the original program. 219216359Sasami if ($self->{'linenums'} && $cx != .5) { # $cx == .5 means in a format 219316359Sasami push @text, "\f#line " . $op->line . 219416359Sasami ' "' . $op->file, qq'"\n'; 219516359Sasami } 219616359Sasami 219716359Sasami push @text, $op->label . ": " if $op->label; 219816359Sasami 219916359Sasami return join("", @text); 220016359Sasami} 220116359Sasami 220216359Sasamisub declare_warnings { 220360472Snyan my ($self, $from, $to) = @_; 220460472Snyan $from //= ''; 220560472Snyan my $all = warnings::bits("all"); 220642262Skato unless (($from & ~$all) =~ /[^\0]/) { 220742262Skato # no FATAL bits need turning off 220860472Snyan if ( $to eq $all) { 220942262Skato return $self->keyword("use") . " warnings;\n"; 221022200Skato } 221122200Skato elsif ($to eq ("\0"x length($to))) { 221222200Skato return $self->keyword("no") . " warnings;\n"; 221322200Skato } 221422200Skato } 221522200Skato 221622200Skato return "BEGIN {\${^WARNING_BITS} = \"" 221722200Skato . join("", map { sprintf("\\x%02x", ord $_) } split "", $to) 221822200Skato . "\"}\n\cK"; 221922200Skato} 222022200Skato 222122200Skatosub declare_hints { 222260472Snyan my ($self, $from, $to) = @_; 222360472Snyan my $use = $to & ~$from; 222460472Snyan my $no = $from & ~$to; 222560472Snyan my $decls = ""; 222660472Snyan for my $pragma (hint_pragmas($use)) { 222760472Snyan $decls .= $self->keyword("use") . " $pragma;\n"; 222816359Sasami } 222916359Sasami for my $pragma (hint_pragmas($no)) { 223042262Skato $decls .= $self->keyword("no") . " $pragma;\n"; 223160472Snyan } 223222200Skato return $decls; 223316359Sasami} 223416359Sasami 223516359Sasami# Internal implementation hints that the core sets automatically, so don't need 223616359Sasami# (or want) to be passed back to the user 223772200Sbmilekicmy %ignored_hints = ( 223816359Sasami 'open<' => 1, 223942262Skato 'open>' => 1, 224042262Skato ':' => 1, 224142262Skato 'strict/refs' => 1, 224242262Skato 'strict/subs' => 1, 224316359Sasami 'strict/vars' => 1, 224416359Sasami 'feature/bits' => 1, 224516359Sasami); 224616359Sasami 224716359Sasamimy %rev_feature; 224816359Sasami 224945783Skatosub declare_hinthash { 225032332Skato my ($self, $from, $to, $indent, $hints) = @_; 225132332Skato my $doing_features = 225232332Skato ($hints & $feature::hint_mask) == $feature::hint_mask; 225332332Skato my @decls; 225432332Skato my @features; 225532332Skato my @unfeatures; # bugs? 225616359Sasami for my $key (sort keys %$to) { 225742262Skato next if $ignored_hints{$key}; 225842262Skato my $is_feature = $key =~ /^feature_/; 225942262Skato next if $is_feature and not $doing_features; 226016359Sasami if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) { 226116359Sasami push(@features, $key), next if $is_feature; 226242262Skato push @decls, 226342262Skato qq(\$^H{) . single_delim("q", "'", $key, $self) . qq(} = ) 226442262Skato . ( 226572200Sbmilekic defined $to->{$key} 226616359Sasami ? single_delim("q", "'", $to->{$key}, $self) 226716359Sasami : 'undef' 226816359Sasami ) 226916359Sasami . qq(;); 227016359Sasami } 227116359Sasami } 227216359Sasami for my $key (sort keys %$from) { 227316359Sasami next if $ignored_hints{$key}; 227416359Sasami my $is_feature = $key =~ /^feature_/; 227516359Sasami next if $is_feature and not $doing_features; 227616359Sasami if (!exists $to->{$key}) { 227716359Sasami push(@unfeatures, $key), next if $is_feature; 227816359Sasami push @decls, qq(delete \$^H{'$key'};); 227916359Sasami } 228016359Sasami } 228116359Sasami my @ret; 228216359Sasami if (@features || @unfeatures) { 228316359Sasami if (!%rev_feature) { %rev_feature = reverse %feature::feature } 228416359Sasami } 228560472Snyan if (@features) { 228616359Sasami push @ret, $self->keyword("use") . " feature " 228716359Sasami . join(", ", map "'$rev_feature{$_}'", @features) . ";\n"; 228860472Snyan } 228916359Sasami if (@unfeatures) { 229016359Sasami push @ret, $self->keyword("no") . " feature " 229116359Sasami . join(", ", map "'$rev_feature{$_}'", @unfeatures) 229216359Sasami . ";\n"; 229316359Sasami } 229416359Sasami @decls and 229516359Sasami push @ret, 229616359Sasami join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n\cK"; 229716359Sasami return @ret; 229816359Sasami} 229916359Sasami 230016359Sasamisub hint_pragmas { 230116359Sasami my ($bits) = @_; 230216359Sasami my (@pragmas, @strict); 230316359Sasami push @pragmas, "integer" if $bits & 0x1; 230416359Sasami for (sort keys %strict_bits) { 230516359Sasami push @strict, "'$_'" if $bits & $strict_bits{$_}; 230616359Sasami } 230716359Sasami if (@strict == keys %strict_bits) { 230816359Sasami push @pragmas, "strict"; 230916359Sasami } 231016359Sasami elsif (@strict) { 231116359Sasami push @pragmas, "strict " . join ', ', @strict; 231216359Sasami } 231316359Sasami push @pragmas, "bytes" if $bits & 0x8; 231416359Sasami return @pragmas; 231516359Sasami} 231616359Sasami 231716359Sasamisub pp_dbstate { pp_nextstate(@_) } 231883434Simpsub pp_setstate { pp_nextstate(@_) } 231916359Sasami 232016359Sasamisub pp_unstack { return "" } # see also leaveloop 232116359Sasami 232283434Simpmy %feature_keywords = ( 232316359Sasami # keyword => 'feature', 232416359Sasami state => 'state', 232516359Sasami say => 'say', 232616359Sasami given => 'switch', 232716359Sasami when => 'switch', 232816359Sasami default => 'switch', 232916359Sasami break => 'switch', 233016359Sasami evalbytes=>'evalbytes', 233116359Sasami __SUB__ => '__SUB__', 233216359Sasami fc => 'fc', 233357928Skato try => 'try', 233457928Skato catch => 'try', 233516359Sasami finally => 'try', 233616359Sasami defer => 'defer', 233716359Sasami signatures => 'signatures', 233816359Sasami); 233916359Sasami 234016359Sasami# keywords that are strong and also have a prototype 234116359Sasami# 234251654Sphkmy %strong_proto_keywords = map { $_ => 1 } qw( 234316359Sasami pos 234416359Sasami prototype 234516359Sasami scalar 234616359Sasami study 234716359Sasami undef 234816359Sasami); 234916359Sasami 235043663Skatosub feature_enabled { 235143663Skato my($self,$name) = @_; 235245816Skato my $hh; 235316359Sasami my $hints = $self->{hints} & $feature::hint_mask; 235416359Sasami if ($hints && $hints != $feature::hint_mask) { 235516359Sasami $hh = _features_from_bundle($hints); 235616359Sasami } 235716359Sasami elsif ($hints) { $hh = $self->{'hinthash'} } 235816359Sasami return $hh && $hh->{"feature_$feature_keywords{$name}"} 235916359Sasami} 236016359Sasami 236116359Sasamisub keyword { 236216359Sasami my $self = shift; 236316359Sasami my $name = shift; 236416359Sasami return $name if $name =~ /^CORE::/; # just in case 236516359Sasami if (exists $feature_keywords{$name}) { 236616359Sasami return "CORE::$name" if not $self->feature_enabled($name); 236716359Sasami } 236816359Sasami # This sub may be called for a program that has no nextstate ops. In 236916359Sasami # that case we may have a lexical sub named no/use/sub in scope but 237022200Skato # $self->lex_in_scope will return false because it depends on the 237122200Skato # current nextstate op. So we need this alternate method if there is 237245226Skato # no current cop. 237316359Sasami if (!$self->{'curcop'}) { 237442262Skato $self->populate_curcvlex() if !defined $self->{'curcvlex'}; 237560472Snyan return "CORE::$name" if exists $self->{'curcvlex'}{"m&$name"} 237660472Snyan || exists $self->{'curcvlex'}{"o&$name"}; 237716359Sasami } elsif ($self->lex_in_scope("&$name") 237860472Snyan || $self->lex_in_scope("&$name", 1)) { 237983539Snyan return "CORE::$name"; 238083539Snyan } 238183539Snyan if ($strong_proto_keywords{$name} 238283539Snyan || ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/ 238383539Snyan && !defined eval{prototype "CORE::$name"}) 238483539Snyan ) { return $name } 238583539Snyan if ( 238683539Snyan exists $self->{subs_declared}{$name} 238783539Snyan or 238883539Snyan exists &{"$self->{curstash}::$name"} 238983539Snyan ) { 239016359Sasami return "CORE::$name" 239116359Sasami } 239283539Snyan return $name; 239342262Skato} 239416359Sasami 239516359Sasamisub baseop { 239660472Snyan my $self = shift; 239760472Snyan my($op, $cx, $name) = @_; 239842262Skato return $self->keyword($name); 239942262Skato} 240016359Sasami 240116359Sasamisub pp_stub { "()" } 240216359Sasamisub pp_wantarray { baseop(@_, "wantarray") } 240383539Snyansub pp_fork { baseop(@_, "fork") } 240483539Snyansub pp_wait { maybe_targmy(@_, \&baseop, "wait") } 240516359Sasamisub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") } 240616359Sasamisub pp_time { maybe_targmy(@_, \&baseop, "time") } 240716359Sasamisub pp_tms { baseop(@_, "times") } 240816359Sasamisub pp_ghostent { baseop(@_, "gethostent") } 240916359Sasamisub pp_gnetent { baseop(@_, "getnetent") } 241016359Sasamisub pp_gprotoent { baseop(@_, "getprotoent") } 241116359Sasamisub pp_gservent { baseop(@_, "getservent") } 241216359Sasamisub pp_ehostent { baseop(@_, "endhostent") } 241316359Sasamisub pp_enetent { baseop(@_, "endnetent") } 241446766Skatosub pp_eprotoent { baseop(@_, "endprotoent") } 241516359Sasamisub pp_eservent { baseop(@_, "endservent") } 241660472Snyansub pp_gpwent { baseop(@_, "getpwent") } 241716359Sasamisub pp_spwent { baseop(@_, "setpwent") } 241846766Skatosub pp_epwent { baseop(@_, "endpwent") } 241916359Sasamisub pp_ggrent { baseop(@_, "getgrent") } 242046766Skatosub pp_sgrent { baseop(@_, "setgrent") } 242116359Sasamisub pp_egrent { baseop(@_, "endgrent") } 242216359Sasamisub pp_getlogin { baseop(@_, "getlogin") } 242342262Skato 242442262Skatosub POSTFIX () { 1 } 242516359Sasami 242616359Sasami# I couldn't think of a good short name, but this is the category of 242716359Sasami# symbolic unary operators with interesting precedence 242825026Skato 242916359Sasamisub pfixop { 243016359Sasami my $self = shift; 243116359Sasami my($op, $cx, $name, $prec, $flags) = (@_, 0); 243216359Sasami my $kid = $op->first; 243316359Sasami $kid = $self->deparse($kid, $prec); 243416359Sasami return $self->maybe_parens(($flags & POSTFIX) 243542262Skato ? "$kid$name" 243660472Snyan # avoid confusion with filetests 243716359Sasami : $name eq '-' 243816359Sasami && $kid =~ /^[a-zA-Z](?!\w)/ 243916359Sasami ? "$name($kid)" 244054174Snyan : "$name$kid", 244154174Snyan $cx, $prec); 244254174Snyan} 244354174Snyan 244454174Snyansub pp_preinc { pfixop(@_, "++", 23) } 244554174Snyansub pp_predec { pfixop(@_, "--", 23) } 244654174Snyansub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } 244716359Sasamisub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } 244816359Sasamisub pp_i_preinc { pfixop(@_, "++", 23) } 244916359Sasamisub pp_i_predec { pfixop(@_, "--", 23) } 245016359Sasamisub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } 245116359Sasamisub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } 245216359Sasamisub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) } 245360472Snyan*pp_ncomplement = *pp_complement; 245416359Sasamisub pp_scomplement { maybe_targmy(@_, \&pfixop, "~.", 21) } 245516359Sasami 245616359Sasamisub pp_negate { maybe_targmy(@_, \&real_negate) } 245716359Sasamisub real_negate { 245816359Sasami my $self = shift; 245916359Sasami my($op, $cx) = @_; 246016359Sasami if ($op->first->name =~ /^(i_)?negate$/) { 246116359Sasami # avoid --$x 246216359Sasami $self->pfixop($op, $cx, "-", 21.5); 246316359Sasami } else { 246416359Sasami $self->pfixop($op, $cx, "-", 21); 246516359Sasami } 246616359Sasami} 246716359Sasamisub pp_i_negate { pp_negate(@_) } 246846871Skato 246916359Sasamisub pp_not { 247016359Sasami my $self = shift; 247116359Sasami my($op, $cx) = @_; 247216359Sasami if ($cx <= 4) { 247346871Skato $self->listop($op, $cx, "not", $op->first); 247457928Skato } else { 247516359Sasami $self->pfixop($op, $cx, "!", 21); 247646871Skato } 247716359Sasami} 247816359Sasami 247916359Sasamisub unop { 248016359Sasami my $self = shift; 248116359Sasami my($op, $cx, $name, $nollafr) = @_; 248216359Sasami my $kid; 248316359Sasami if ($op->flags & OPf_KIDS) { 248416359Sasami $kid = $op->first; 248516359Sasami if (not $name) { 248646871Skato # this deals with 'boolkeys' right now 248716359Sasami return $self->deparse($kid,$cx); 248816359Sasami } 248916359Sasami my $builtinname = $name; 249016359Sasami $builtinname =~ /^CORE::/ or $builtinname = "CORE::$name"; 249116359Sasami if (defined prototype($builtinname) 249216359Sasami && $builtinname ne 'CORE::readline' 249316359Sasami && prototype($builtinname) =~ /^;?\*/ 249446871Skato && $kid->name eq "rv2gv") { 249557928Skato $kid = $kid->first; 249616359Sasami } 249716359Sasami 249816359Sasami if ($nollafr) { 249916359Sasami if (($kid = $self->deparse($kid, 16)) !~ s/^\cS//) { 250016359Sasami # require foo() is a syntax error. 250116359Sasami $kid =~ /^(?!\d)\w/ and $kid = "($kid)"; 250216359Sasami } 250316359Sasami return $self->maybe_parens( 250416359Sasami $self->keyword($name) . " $kid", $cx, 16 250546871Skato ); 250616359Sasami } 250716359Sasami return $self->maybe_parens_unop($name, $kid, $cx); 250816359Sasami } else { 250920129Sasami return $self->maybe_parens( 251020129Sasami $self->keyword($name) . ($op->flags & OPf_SPECIAL ? "()" : ""), 251120129Sasami $cx, 16, 251220129Sasami ); 251320129Sasami } 251420129Sasami} 251520129Sasami 251620129Sasamisub pp_chop { maybe_targmy(@_, \&unop, "chop") } 251720129Sasamisub pp_chomp { maybe_targmy(@_, \&unop, "chomp") } 251820129Sasamisub pp_schop { maybe_targmy(@_, \&unop, "chop") } 251920129Sasamisub pp_schomp { maybe_targmy(@_, \&unop, "chomp") } 252025026Skatosub pp_defined { unop(@_, "defined") } 252120129Sasamisub pp_undef { 252220129Sasami if ($_[1]->private & OPpTARGET_MY) { 252320129Sasami my $targ = $_[1]->targ; 252420129Sasami my $var = $_[0]->maybe_my($_[1], $_[2], $_[0]->padname($targ), 252520129Sasami $_[0]->padname_sv($targ), 252620129Sasami 1); 252725026Skato my $func = unop(@_, "undef"); 252823447Skato if ($func =~ /\s/) { 252943539Skato return unop(@_, "undef").$var; 253054174Snyan } else { 253154174Snyan return "$var = undef"; 253254174Snyan } 253354174Snyan } 253454174Snyan unop(@_, "undef") 253554174Snyan} 253654174Snyansub pp_study { unop(@_, "study") } 253754174Snyansub pp_ref { unop(@_, "ref") } 253823447Skatosub pp_pos { maybe_local(@_, unop(@_, "pos")) } 253920129Sasami 254020129Sasamisub pp_sin { maybe_targmy(@_, \&unop, "sin") } 254123447Skatosub pp_cos { maybe_targmy(@_, \&unop, "cos") } 254220129Sasamisub pp_rand { maybe_targmy(@_, \&unop, "rand") } 254320129Sasamisub pp_srand { unop(@_, "srand") } 254425026Skatosub pp_exp { maybe_targmy(@_, \&unop, "exp") } 254520129Sasamisub pp_log { maybe_targmy(@_, \&unop, "log") } 254620129Sasamisub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") } 254720129Sasamisub pp_int { maybe_targmy(@_, \&unop, "int") } 254820129Sasamisub pp_hex { maybe_targmy(@_, \&unop, "hex") } 254920129Sasamisub pp_oct { maybe_targmy(@_, \&unop, "oct") } 255020129Sasamisub pp_abs { maybe_targmy(@_, \&unop, "abs") } 255116359Sasami 255216359Sasamisub pp_length { maybe_targmy(@_, \&unop, "length") } 255316359Sasamisub pp_ord { maybe_targmy(@_, \&unop, "ord") } 255416359Sasamisub pp_chr { maybe_targmy(@_, \&unop, "chr") } 255516359Sasami 255616359Sasamisub pp_each { unop(@_, "each") } 255716359Sasamisub pp_values { unop(@_, "values") } 255816359Sasamisub pp_keys { unop(@_, "keys") } 255916359Sasami{ no strict 'refs'; *{"pp_r$_"} = *{"pp_$_"} for qw< keys each values >; } 256016359Sasamisub pp_boolkeys { 256165568Skato # no name because its an optimisation op that has no keyword 256271713Snyan unop(@_,""); 256371713Snyan} 256465568Skatosub pp_aeach { unop(@_, "each") } 256540565Sbdesub pp_avalues { unop(@_, "values") } 256643663Skatosub pp_akeys { unop(@_, "keys") } 256743663Skatosub pp_pop { unop(@_, "pop") } 256843663Skatosub pp_shift { unop(@_, "shift") } 256943663Skato 257043663Skatosub pp_caller { unop(@_, "caller") } 257143663Skatosub pp_reset { unop(@_, "reset") } 257243663Skatosub pp_exit { unop(@_, "exit") } 257343663Skatosub pp_prototype { unop(@_, "prototype") } 257443663Skato 257543663Skatosub pp_close { unop(@_, "close") } 257643663Skatosub pp_fileno { unop(@_, "fileno") } 257743663Skatosub pp_umask { unop(@_, "umask") } 257843663Skatosub pp_untie { unop(@_, "untie") } 257943663Skatosub pp_tied { unop(@_, "tied") } 258043663Skatosub pp_dbmclose { unop(@_, "dbmclose") } 258143663Skatosub pp_getc { unop(@_, "getc") } 258243663Skatosub pp_eof { unop(@_, "eof") } 258343663Skatosub pp_tell { unop(@_, "tell") } 258443663Skatosub pp_getsockname { unop(@_, "getsockname") } 258543663Skatosub pp_getpeername { unop(@_, "getpeername") } 258643663Skato 258743663Skatosub pp_chdir { 258843663Skato my ($self, $op, $cx) = @_; 258943663Skato if (($op->flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS)) { 259043663Skato my $kw = $self->keyword("chdir"); 259165568Skato my $kid = $self->const_sv($op->first)->PV; 259265568Skato my $code = $kw 259365568Skato . ($cx >= 16 || $self->{'parens'} ? "($kid)" : " $kid"); 259465568Skato maybe_targmy(@_, sub { $_[3] }, $code); 259565568Skato } else { 259672200Sbmilekic maybe_targmy(@_, \&unop, "chdir") 259743663Skato } 259843663Skato} 259943663Skato 260043663Skatosub pp_chroot { maybe_targmy(@_, \&unop, "chroot") } 260143663Skatosub pp_readlink { unop(@_, "readlink") } 260243663Skatosub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") } 260343663Skatosub pp_readdir { unop(@_, "readdir") } 260443663Skatosub pp_telldir { unop(@_, "telldir") } 260543663Skatosub pp_rewinddir { unop(@_, "rewinddir") } 260643663Skatosub pp_closedir { unop(@_, "closedir") } 260743663Skatosub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") } 260843663Skatosub pp_localtime { unop(@_, "localtime") } 260943663Skatosub pp_gmtime { unop(@_, "gmtime") } 261043663Skatosub pp_alarm { unop(@_, "alarm") } 261143663Skatosub pp_sleep { maybe_targmy(@_, \&unop, "sleep") } 261243663Skato 261343663Skatosub pp_dofile { 261443663Skato my $code = unop(@_, "do", 1); # llafr does not apply 261543663Skato if ($code =~ s/^((?:CORE::)?do) \{/$1({/) { $code .= ')' } 261643663Skato $code; 261772200Sbmilekic} 261843663Skatosub pp_entereval { 261943663Skato unop( 262043663Skato @_, 262165568Skato $_[1]->private & OPpEVAL_BYTES ? 'evalbytes' : "eval" 262265568Skato ) 262365568Skato} 262465568Skato 262565568Skatosub pp_ghbyname { unop(@_, "gethostbyname") } 262672200Sbmilekicsub pp_gnbyname { unop(@_, "getnetbyname") } 262743663Skatosub pp_gpbyname { unop(@_, "getprotobyname") } 262843663Skatosub pp_shostent { unop(@_, "sethostent") } 262943663Skatosub pp_snetent { unop(@_, "setnetent") } 263043663Skatosub pp_sprotoent { unop(@_, "setprotoent") } 263143663Skatosub pp_sservent { unop(@_, "setservent") } 263243663Skatosub pp_gpwnam { unop(@_, "getpwnam") } 263343663Skatosub pp_gpwuid { unop(@_, "getpwuid") } 263443663Skatosub pp_ggrnam { unop(@_, "getgrnam") } 263543663Skatosub pp_ggrgid { unop(@_, "getgrgid") } 263643663Skato 263743663Skatosub pp_lock { unop(@_, "lock") } 263843663Skato 263943663Skatosub pp_continue { unop(@_, "continue"); } 264043663Skatosub pp_break { unop(@_, "break"); } 264172200Sbmilekic 264243663Skatosub givwhen { 264343663Skato my $self = shift; 264443663Skato my($op, $cx, $givwhen) = @_; 264543663Skato 264643663Skato my $enterop = $op->first; 264743663Skato my ($head, $block); 264843663Skato if ($enterop->flags & OPf_SPECIAL) { 264943663Skato $head = $self->keyword("default"); 265043663Skato $block = $self->deparse($enterop->first, 0); 265143663Skato } 265243663Skato else { 265353884Snyan my $cond = $enterop->first; 265453884Snyan my $cond_str = $self->deparse($cond, 1); 265553884Snyan $head = "$givwhen ($cond_str)"; 265653884Snyan $block = $self->deparse($cond->sibling, 0); 265743663Skato } 265853884Snyan 265953884Snyan return "$head {\n". 266053884Snyan "\t$block\n". 266153884Snyan "\b}\cK"; 266243663Skato} 266353884Snyan 266443663Skatosub pp_leavegiven { givwhen(@_, $_[0]->keyword("given")); } 266543663Skatosub pp_leavewhen { givwhen(@_, $_[0]->keyword("when")); } 266643663Skato 266743663Skatosub pp_exists { 266843663Skato my $self = shift; 266943663Skato my($op, $cx) = @_; 267043663Skato my $arg; 267145783Skato my $name = $self->keyword("exists"); 267245783Skato if ($op->private & OPpEXISTS_SUB) { 267345783Skato # Checking for the existence of a subroutine 267416359Sasami return $self->maybe_parens_func($name, 267546871Skato $self->pp_rv2cv($op->first, 16), $cx, 16); 267642262Skato } 267742262Skato if ($op->flags & OPf_SPECIAL) { 267842262Skato # Array element, not hash element 267916359Sasami return $self->maybe_parens_func($name, 268071713Snyan $self->pp_aelem($op->first, 16), $cx, 16); 268171713Snyan } 268271713Snyan return $self->maybe_parens_func($name, $self->pp_helem($op->first, 16), 268372200Sbmilekic $cx, 16); 268471713Snyan} 268572200Sbmilekic 268671713Snyansub pp_delete { 268771713Snyan my $self = shift; 268871713Snyan my($op, $cx) = @_; 268971713Snyan my $arg; 269016359Sasami my $name = $self->keyword("delete"); 269116359Sasami if ($op->private & (OPpSLICE|OPpKVSLICE)) { 269216359Sasami if ($op->flags & OPf_SPECIAL) { 269316359Sasami # Deleting from an array, not a hash 269416359Sasami return $self->maybe_parens_func($name, 269516359Sasami $self->pp_aslice($op->first, 16), 269616359Sasami $cx, 16); 269772200Sbmilekic } 269816359Sasami return $self->maybe_parens_func($name, 269916359Sasami $self->pp_hslice($op->first, 16), 270053373Snyan $cx, 16); 270116359Sasami } else { 270228939Skato if ($op->flags & OPf_SPECIAL) { 270329010Skato # Deleting from an array, not a hash 270428939Skato return $self->maybe_parens_func($name, 270528939Skato $self->pp_aelem($op->first, 16), 270616359Sasami $cx, 16); 270716359Sasami } 270816359Sasami return $self->maybe_parens_func($name, 270960472Snyan $self->pp_helem($op->first, 16), 271016359Sasami $cx, 16); 271160472Snyan } 271216359Sasami} 271342262Skato 271460472Snyansub pp_require { 271560472Snyan my $self = shift; 271660472Snyan my($op, $cx) = @_; 271760472Snyan my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require'; 271860472Snyan my $kid = $op->first; 271960472Snyan if ($kid->name eq 'const') { 272060472Snyan my $priv = $kid->private; 272160472Snyan my $sv = $self->const_sv($kid); 272260472Snyan my $arg; 272342262Skato if ($priv & OPpCONST_BARE) { 272442262Skato $arg = $sv->PV; 272542262Skato $arg =~ s[/][::]g; 272642262Skato $arg =~ s/\.pm//g; 272716359Sasami } elsif ($priv & OPpCONST_NOVER) { 272816359Sasami $opname = $self->keyword('no'); 272916359Sasami $arg = $self->const($sv, 16); 273016359Sasami } elsif ((my $tmp = $self->const($sv, 16)) =~ /^v/) { 273116359Sasami $arg = $tmp; 273229010Skato } 273316359Sasami if ($arg) { 273416359Sasami return $self->maybe_parens("$opname $arg", $cx, 16); 273572200Sbmilekic } 273616359Sasami } 273716359Sasami $self->unop( 273816359Sasami $op, $cx, 273916359Sasami $opname, 274016359Sasami 1, # llafr does not apply 274116359Sasami ); 274216359Sasami} 274316359Sasami 274416359Sasamisub pp_scalar { 274516359Sasami my $self = shift; 274616359Sasami my($op, $cx) = @_; 274732332Skato my $kid = $op->first; 274832332Skato if (not null $kid->sibling) { 274945226Skato # XXX Was a here-doc 275045226Skato return $self->dquote($op); 275132332Skato } 275216359Sasami $self->unop(@_, "scalar"); 275360472Snyan} 275442262Skato 275560472Snyan 275616359Sasamisub padval { 275716359Sasami my $self = shift; 275832332Skato my $targ = shift; 275932332Skato return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ); 276032332Skato} 276133378Skato 276216359Sasamisub anon_hash_or_list { 276316359Sasami my $self = shift; 276416359Sasami my($op, $cx) = @_; 276554174Snyan 276654174Snyan my($pre, $post) = @{{"anonlist" => ["[","]"], 276754174Snyan "anonhash" => ["{","}"]}->{$op->name}}; 276854174Snyan my($expr, @exprs); 276916359Sasami $op = $op->first->sibling; # skip pushmark 277016359Sasami for (; !null($op); $op = $op->sibling) { 277154174Snyan $expr = $self->deparse($op, 6); 277254174Snyan push @exprs, $expr; 277354174Snyan } 277454174Snyan if ($pre eq "{" and $cx < 1) { 277554174Snyan # Disambiguate that it's not a block 277654174Snyan $pre = "+{"; 277754174Snyan } 277854174Snyan return $pre . join(", ", @exprs) . $post; 277954174Snyan} 278054174Snyan 278154174Snyansub pp_anonlist { 278254174Snyan my $self = shift; 278354174Snyan my ($op, $cx) = @_; 278454174Snyan if ($op->flags & OPf_SPECIAL) { 278554174Snyan return $self->anon_hash_or_list($op, $cx); 278654174Snyan } 278746460Skato warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL"; 278816359Sasami return 'XXX'; 278945226Skato} 279045226Skato 279145226Skato*pp_anonhash = \&pp_anonlist; 279245226Skato 279345226Skatosub pp_emptyavhv { 279445226Skato my $self = shift; 279545226Skato my ($op, $cx, $forbid_parens) = @_; 279651202Snyan my $val = ($op->private & OPpEMPTYAVHV_IS_HV) ? '{}' : '[]'; 279745226Skato if ($op->private & OPpTARGET_MY) { 279845226Skato my $targ = $op->targ; 279916359Sasami my $var = $self->maybe_my($op, $cx, $self->padname($targ), 280042262Skato $self->padname_sv($targ), 280146460Skato $forbid_parens); 280242262Skato return $self->maybe_parens("$var = $val", $cx, 7); 280342262Skato } else { 280442262Skato return $val; 280516359Sasami } 280616359Sasami} 280742262Skato 280816359Sasamisub pp_refgen { 280942262Skato my $self = shift; 281042262Skato my($op, $cx) = @_; 281142262Skato my $kid = $op->first; 281242262Skato if ($kid->name eq "null") { 281342262Skato my $anoncode = $kid = $kid->first; 281416359Sasami 281516359Sasami # Perl no longer generates this, but XS modules might: 281642262Skato if ($anoncode->name eq "anonconst") { 281754174Snyan $anoncode = $anoncode->first->first->sibling; 281854174Snyan } 281954174Snyan 282054174Snyan # Same as with `anonconst`: 282154174Snyan if ($anoncode->name eq "anoncode" 282216359Sasami or !null($anoncode = $kid->sibling) and 282354174Snyan $anoncode->name eq "anoncode") { 282454174Snyan return $self->e_anoncode({ code => $self->padval($anoncode->targ) }); 282554174Snyan 282654174Snyan # Perl still generates this: 282754174Snyan } elsif ($kid->name eq "pushmark") { 282854174Snyan my $sib_name = $kid->sibling->name; 282954174Snyan if ($sib_name eq 'entersub') { 283054174Snyan my $text = $self->deparse($kid->sibling, 1); 283116359Sasami # Always show parens for \(&func()), but only with -p otherwise 283260472Snyan $text = "($text)" if $self->{'parens'} 283354174Snyan or $kid->sibling->private & OPpENTERSUB_AMPER; 283454174Snyan return "\\$text"; 283554174Snyan } 283654174Snyan } 283742262Skato } 283842262Skato local $self->{'in_refgen'} = 1; 283916359Sasami $self->pfixop($op, $cx, "\\", 20); 284016359Sasami} 284116359Sasami 284216359Sasamisub e_anoncode { 284383539Snyan my ($self, $info) = @_; 284483539Snyan my $text = $self->deparse_sub($info->{code}); 284583539Snyan return $self->keyword("sub") . " $text"; 284683539Snyan} 284783539Snyan 284883539Snyansub pp_anoncode { 284983539Snyan my ($self, $anoncode) = @_; 285083539Snyan 285183539Snyan return $self->e_anoncode( { code => $self->padval($anoncode->targ) } ); 285283539Snyan} 285383539Snyan 285483539Snyansub pp_anonconst { 285583539Snyan my ($self, $anonconst) = @_; 285683539Snyan 285783539Snyan return $self->pp_anoncode( $anonconst->first->first->sibling ); 285883539Snyan} 285983539Snyan 286083539Snyansub pp_srefgen { pp_refgen(@_) } 286183539Snyan 286283539Snyansub pp_readline { 286383539Snyan my $self = shift; 286483539Snyan my($op, $cx) = @_; 286583539Snyan my $kid = $op->first; 286683539Snyan if (is_scalar($kid) 286783539Snyan and $op->flags & OPf_SPECIAL 286883539Snyan and $self->deparse($kid, 1) eq 'ARGV') 286983539Snyan { 287083539Snyan return '<<>>'; 287183539Snyan } 287220129Sasami return $self->unop($op, $cx, "readline"); 287320129Sasami} 287420129Sasami 287520129Sasamisub pp_rcatline { 287620129Sasami my $self = shift; 287720129Sasami my($op) = @_; 287820129Sasami return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">"; 287920129Sasami} 288020129Sasami 288120129Sasami# Unary operators that can occur as pseudo-listops inside double quotes 288220129Sasamisub dq_unop { 288320129Sasami my $self = shift; 288420129Sasami my($op, $cx, $name, $prec, $flags) = (@_, 0, 0); 288520129Sasami my $kid; 288620129Sasami if ($op->flags & OPf_KIDS) { 288720129Sasami $kid = $op->first; 288820898Skato # If there's more than one kid, the first is an ex-pushmark. 288920129Sasami $kid = $kid->sibling if not null $kid->sibling; 289020129Sasami return $self->maybe_parens_unop($name, $kid, $cx); 289120129Sasami } else { 289220129Sasami return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); 289320129Sasami } 289420129Sasami} 289520129Sasami 289620129Sasamisub pp_ucfirst { dq_unop(@_, "ucfirst") } 289720129Sasamisub pp_lcfirst { dq_unop(@_, "lcfirst") } 289820129Sasamisub pp_uc { dq_unop(@_, "uc") } 289916359Sasamisub pp_lc { dq_unop(@_, "lc") } 290020129Sasamisub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") } 290120129Sasamisub pp_fc { dq_unop(@_, "fc") } 290220129Sasami 290316359Sasamisub loopex { 290416359Sasami my $self = shift; 290516359Sasami my ($op, $cx, $name) = @_; 290616359Sasami if (class($op) eq "PVOP") { 290772431Skato $name .= " " . $op->pv; 290816359Sasami } elsif (class($op) eq "OP") { 290916359Sasami # no-op 291016359Sasami } elsif (class($op) eq "UNOP") { 291116359Sasami (my $kid = $self->deparse($op->first, 7)) =~ s/^\cS//; 291217256Sasami # last foo() is a syntax error. 291317256Sasami $kid =~ /^(?!\d)\w/ and $kid = "($kid)"; 291416359Sasami $name .= " $kid"; 291572431Skato } 291616359Sasami return $self->maybe_parens($name, $cx, 7); 291716359Sasami} 291872431Skato 291916359Sasamisub pp_last { loopex(@_, "last") } 292016359Sasamisub pp_next { loopex(@_, "next") } 292143663Skatosub pp_redo { loopex(@_, "redo") } 292216359Sasamisub pp_goto { loopex(@_, "goto") } 292316359Sasamisub pp_dump { loopex(@_, "CORE::dump") } 292416359Sasami 292516359Sasamisub ftst { 292653884Snyan my $self = shift; 292753884Snyan my($op, $cx, $name) = @_; 292816359Sasami if (class($op) eq "UNOP") { 292916359Sasami # Genuine '-X' filetests are exempt from the LLAFR, but not 293016359Sasami # l?stat() 293116359Sasami if ($name =~ /^-/) { 293216359Sasami (my $kid = $self->deparse($op->first, 16)) =~ s/^\cS//; 293316359Sasami return $self->maybe_parens("$name $kid", $cx, 16); 293416359Sasami } 293516359Sasami return $self->maybe_parens_unop($name, $op->first, $cx); 293616359Sasami } elsif (class($op) =~ /^(SV|PAD)OP$/) { 293716359Sasami return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16); 293816359Sasami } else { # I don't think baseop filetests ever survive ck_ftst, but... 293916359Sasami return $name; 294042262Skato } 294116359Sasami} 294216359Sasami 294316359Sasamisub pp_lstat { ftst(@_, "lstat") } 294416359Sasamisub pp_stat { ftst(@_, "stat") } 294542262Skatosub pp_ftrread { ftst(@_, "-R") } 294642262Skatosub pp_ftrwrite { ftst(@_, "-W") } 294742262Skatosub pp_ftrexec { ftst(@_, "-X") } 294842262Skatosub pp_fteread { ftst(@_, "-r") } 294916359Sasamisub pp_ftewrite { ftst(@_, "-w") } 295016359Sasamisub pp_fteexec { ftst(@_, "-x") } 295116359Sasamisub pp_ftis { ftst(@_, "-e") } 295216359Sasamisub pp_fteowned { ftst(@_, "-O") } 295342262Skatosub pp_ftrowned { ftst(@_, "-o") } 295416359Sasamisub pp_ftzero { ftst(@_, "-z") } 295516359Sasamisub pp_ftsize { ftst(@_, "-s") } 295616359Sasamisub pp_ftmtime { ftst(@_, "-M") } 295717256Sasamisub pp_ftatime { ftst(@_, "-A") } 295817256Sasamisub pp_ftctime { ftst(@_, "-C") } 295917256Sasamisub pp_ftsock { ftst(@_, "-S") } 296017256Sasamisub pp_ftchr { ftst(@_, "-c") } 296117256Sasamisub pp_ftblk { ftst(@_, "-b") } 296216359Sasamisub pp_ftfile { ftst(@_, "-f") } 296316359Sasamisub pp_ftdir { ftst(@_, "-d") } 296416359Sasamisub pp_ftpipe { ftst(@_, "-p") } 296516359Sasamisub pp_ftlink { ftst(@_, "-l") } 296616359Sasamisub pp_ftsuid { ftst(@_, "-u") } 296716359Sasamisub pp_ftsgid { ftst(@_, "-g") } 296816359Sasamisub pp_ftsvtx { ftst(@_, "-k") } 296916359Sasamisub pp_fttty { ftst(@_, "-t") } 297016359Sasamisub pp_fttext { ftst(@_, "-T") } 297116359Sasamisub pp_ftbinary { ftst(@_, "-B") } 297272431Skato 297316359Sasamisub SWAP_CHILDREN () { 1 } 297416359Sasamisub ASSIGN () { 2 } # has OP= variant 297516359Sasamisub LIST_CONTEXT () { 4 } # Assignment is in list context 297616359Sasami 297716359Sasamimy(%left, %right); 297816359Sasami 297916359Sasamisub assoc_class { 298016359Sasami my $op = shift; 298116359Sasami my $name = $op->name; 298216359Sasami if ($name eq "concat" and $op->first->name eq "concat") { 298316359Sasami # avoid spurious '=' -- see comment in pp_concat 298416359Sasami return "concat"; 298516359Sasami } 298616359Sasami if ($name eq "null" and class($op) eq "UNOP" 298716359Sasami and $op->first->name =~ /^(and|x?or)$/ 298842262Skato and null $op->first->sibling) 298916359Sasami { 299016359Sasami # Like all conditional constructs, OP_ANDs and OP_ORs are topped 299142262Skato # with a null that's used as the common end point of the two 299242262Skato # flows of control. For precedence purposes, ignore it. 299342262Skato # (COND_EXPRs have these too, but we don't bother with 299442262Skato # their associativity). 299542262Skato return assoc_class($op->first); 299642262Skato } 299754174Snyan return $name . ($op->flags & OPf_STACKED ? "=" : ""); 299854174Snyan} 299954174Snyan 300054174Snyan# Left associative operators, like '+', for which 300154174Snyan# $a + $b + $c is equivalent to ($a + $b) + $c 300254174Snyan 300354174SnyanBEGIN { 300454174Snyan %left = ('multiply' => 19, 'i_multiply' => 19, 300554174Snyan 'divide' => 19, 'i_divide' => 19, 300654174Snyan 'modulo' => 19, 'i_modulo' => 19, 300716359Sasami 'repeat' => 19, 300816359Sasami 'add' => 18, 'i_add' => 18, 300916359Sasami 'subtract' => 18, 'i_subtract' => 18, 301016359Sasami 'concat' => 18, 301116359Sasami 'left_shift' => 17, 'right_shift' => 17, 301242262Skato 'bit_and' => 13, 'nbit_and' => 13, 'sbit_and' => 13, 301342262Skato 'bit_or' => 12, 'bit_xor' => 12, 301442262Skato 'sbit_or' => 12, 'sbit_xor' => 12, 301542262Skato 'nbit_or' => 12, 'nbit_xor' => 12, 301642262Skato 'and' => 3, 301754174Snyan 'or' => 2, 'xor' => 2, 301842262Skato ); 301954174Snyan} 302042262Skato 302142262Skatosub deparse_binop_left { 302216359Sasami my $self = shift; 302316359Sasami my($op, $left, $prec) = @_; 302416359Sasami if ($left{assoc_class($op)} && $left{assoc_class($left)} 302516359Sasami and $left{assoc_class($op)} == $left{assoc_class($left)}) 302654174Snyan { 302754174Snyan return $self->deparse($left, $prec - .00001); 302854174Snyan } else { 302916359Sasami return $self->deparse($left, $prec); 303054174Snyan } 303116359Sasami} 303216359Sasami 303354174Snyan# Right associative operators, like '=', for which 303454174Snyan# $a = $b = $c is equivalent to $a = ($b = $c) 303554174Snyan 303616359SasamiBEGIN { 303754174Snyan %right = ('pow' => 22, 303816359Sasami 'sassign=' => 7, 'aassign=' => 7, 303916359Sasami 'multiply=' => 7, 'i_multiply=' => 7, 304016359Sasami 'divide=' => 7, 'i_divide=' => 7, 304142262Skato 'modulo=' => 7, 'i_modulo=' => 7, 304242262Skato 'repeat=' => 7, 'refassign' => 7, 'refassign=' => 7, 304360472Snyan 'add=' => 7, 'i_add=' => 7, 304416359Sasami 'subtract=' => 7, 'i_subtract=' => 7, 304516359Sasami 'concat=' => 7, 304645783Skato 'left_shift=' => 7, 'right_shift=' => 7, 304732332Skato 'bit_and=' => 7, 'sbit_and=' => 7, 'nbit_and=' => 7, 304832332Skato 'nbit_or=' => 7, 'nbit_xor=' => 7, 304916359Sasami 'sbit_or=' => 7, 'sbit_xor=' => 7, 305016359Sasami 'andassign' => 7, 305117256Sasami 'orassign' => 7, 305216359Sasami ); 305316359Sasami} 305416359Sasami 305516359Sasamisub deparse_binop_right { 305616359Sasami my $self = shift; 305716359Sasami my($op, $right, $prec) = @_; 305816359Sasami if ($right{assoc_class($op)} && $right{assoc_class($right)} 305916359Sasami and $right{assoc_class($op)} == $right{assoc_class($right)}) 306016359Sasami { 306153373Snyan return $self->deparse($right, $prec - .00001); 306232332Skato } else { 306332332Skato return $self->deparse($right, $prec); 306416359Sasami } 306517256Sasami} 306660472Snyan 306760472Snyansub binop { 306842262Skato my $self = shift; 306917256Sasami my ($op, $cx, $opname, $prec, $flags) = (@_, 0); 307016359Sasami my $left = $op->first; 307116359Sasami my $right = $op->last; 307216359Sasami my $eq = ""; 307316359Sasami if ($op->flags & OPf_STACKED && $flags & ASSIGN) { 307467551Sjhb $eq = "="; 307572431Skato $prec = 7; 307616359Sasami } 307716359Sasami if ($flags & SWAP_CHILDREN) { 307853373Snyan ($left, $right) = ($right, $left); 307943663Skato } 308042262Skato my $leftop = $left; 308153373Snyan $left = $self->deparse_binop_left($op, $left, $prec); 308253373Snyan $left = "($left)" if $flags & LIST_CONTEXT 308353373Snyan and $left !~ /^(my|our|local|state|)\s*[\@%\(]/ 308442262Skato || do { 308543663Skato # Parenthesize if the left argument is a 308632332Skato # lone repeat op. 308732332Skato my $left = $leftop->first->sibling; 308816359Sasami $left->name eq 'repeat' 308916359Sasami && null($left->sibling); 309016359Sasami }; 309142262Skato $right = $self->deparse_binop_right($op, $right, $prec); 309260472Snyan return $self->maybe_parens("$left $opname$eq $right", $cx, $prec); 309342262Skato} 309416359Sasami 309554174Snyansub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } 309654174Snyansub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } 309754174Snyansub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) } 309854174Snyansub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } 309954174Snyansub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } 310054174Snyansub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } 310154174Snyansub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } 310254174Snyansub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) } 310354174Snyansub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } 310416359Sasamisub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } 310516359Sasamisub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) } 310616359Sasami 310716359Sasamisub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) } 310816359Sasamisub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) } 310942262Skatosub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) } 311016359Sasamisub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) } 311116359Sasamisub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) } 311216359Sasami*pp_nbit_and = *pp_bit_and; 311316359Sasami*pp_nbit_or = *pp_bit_or; 311416359Sasami*pp_nbit_xor = *pp_bit_xor; 311516359Sasamisub pp_sbit_and { maybe_targmy(@_, \&binop, "&.", 13, ASSIGN) } 311616359Sasamisub pp_sbit_or { maybe_targmy(@_, \&binop, "|.", 12, ASSIGN) } 311716359Sasamisub pp_sbit_xor { maybe_targmy(@_, \&binop, "^.", 12, ASSIGN) } 311816359Sasami 311983434Simpsub pp_eq { binop(@_, "==", 14) } 312016359Sasamisub pp_ne { binop(@_, "!=", 14) } 312136762Skatosub pp_lt { binop(@_, "<", 15) } 312216359Sasamisub pp_gt { binop(@_, ">", 15) } 312316359Sasamisub pp_ge { binop(@_, ">=", 15) } 312483434Simpsub pp_le { binop(@_, "<=", 15) } 312516359Sasamisub pp_ncmp { binop(@_, "<=>", 14) } 312616359Sasamisub pp_i_eq { binop(@_, "==", 14) } 312716359Sasamisub pp_i_ne { binop(@_, "!=", 14) } 312816359Sasamisub pp_i_lt { binop(@_, "<", 15) } 312916359Sasamisub pp_i_gt { binop(@_, ">", 15) } 313016359Sasamisub pp_i_ge { binop(@_, ">=", 15) } 313116359Sasamisub pp_i_le { binop(@_, "<=", 15) } 313245783Skatosub pp_i_ncmp { maybe_targmy(@_, \&binop, "<=>", 14) } 313316359Sasami 313416359Sasamisub pp_seq { binop(@_, "eq", 14) } 313516359Sasamisub pp_sne { binop(@_, "ne", 14) } 313616359Sasamisub pp_slt { binop(@_, "lt", 15) } 313716359Sasamisub pp_sgt { binop(@_, "gt", 15) } 313857928Skatosub pp_sge { binop(@_, "ge", 15) } 313916359Sasamisub pp_sle { binop(@_, "le", 15) } 314016359Sasamisub pp_scmp { maybe_targmy(@_, \&binop, "cmp", 14) } 314116359Sasami 314216359Sasamisub pp_isa { binop(@_, "isa", 15) } 314316359Sasami 314416359Sasamisub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) } 314516359Sasamisub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) } 314616359Sasami 314716359Sasamisub pp_padsv_store { 314816359Sasami my $self = shift; 314916359Sasami my ($op, $cx, $forbid_parens, @args) = @_; 315016359Sasami my $targ = $op->targ; 315116359Sasami my $var = $self->maybe_my($op, $cx, $self->padname($targ), 315216359Sasami $self->padname_sv($targ), 315316359Sasami $forbid_parens); 315416359Sasami 315583434Simp my $val = $self->deparse($op->first, 7); 315616359Sasami return $self->maybe_parens("$var = $val", $cx, 7); 315716359Sasami} 315816359Sasami 315916359Sasamisub pp_smartmatch { 316016359Sasami my ($self, $op, $cx) = @_; 316116359Sasami if (($op->flags & OPf_SPECIAL) && $self->{expand} < 2) { 316216359Sasami return $self->deparse($op->last, $cx); 316316359Sasami } 316416359Sasami else { 316516359Sasami binop(@_, "~~", 14); 316616359Sasami } 316716359Sasami} 316816359Sasami 316916359Sasami# '.' is special because concats-of-concats are optimized to save copying 317016359Sasami# by making all but the first concat stacked. The effect is as if the 317116359Sasami# programmer had written '($a . $b) .= $c', except legal. 317216359Sasamisub pp_concat { maybe_targmy(@_, \&real_concat) } 317316359Sasamisub real_concat { 317416359Sasami my $self = shift; 317516359Sasami my($op, $cx) = @_; 317616359Sasami my $left = $op->first; 317716359Sasami my $right = $op->last; 317816359Sasami my $eq = ""; 317916359Sasami my $prec = 18; 318016359Sasami if (($op->flags & OPf_STACKED) and !($op->private & OPpCONCAT_NESTED)) { 318116359Sasami # '.=' rather than optimised '.' 318216359Sasami $eq = "="; 318316359Sasami $prec = 7; 318416359Sasami } 318516359Sasami $left = $self->deparse_binop_left($op, $left, $prec); 318616359Sasami $right = $self->deparse_binop_right($op, $right, $prec); 318716359Sasami return $self->maybe_parens("$left .$eq $right", $cx, $prec); 318816359Sasami} 318916359Sasami 319016359Sasamisub pp_repeat { maybe_targmy(@_, \&repeat) } 319116359Sasami 319216359Sasami# 'x' is weird when the left arg is a list 319316359Sasamisub repeat { 319416359Sasami my $self = shift; 319516359Sasami my($op, $cx) = @_; 319616359Sasami my $left = $op->first; 319716359Sasami my $right = $op->last; 319816359Sasami my $eq = ""; 319916359Sasami my $prec = 19; 320016359Sasami if ($op->flags & OPf_STACKED) { 320116359Sasami $eq = "="; 320216359Sasami $prec = 7; 320316359Sasami } 320416359Sasami if (null($right)) { # list repeat; count is inside left-side ex-list 320583434Simp # in 5.21.5 and earlier 320631577Sbde my $kid = $left->first->sibling; # skip pushmark 320716359Sasami my @exprs; 320816359Sasami for (; !null($kid->sibling); $kid = $kid->sibling) { 320916359Sasami push @exprs, $self->deparse($kid, 6); 321016359Sasami } 321131577Sbde $right = $kid; 321216359Sasami $left = "(" . join(", ", @exprs). ")"; 321316359Sasami } else { 321416359Sasami my $dolist = $op->private & OPpREPEAT_DOLIST; 321516359Sasami $left = $self->deparse_binop_left($op, $left, $dolist ? 1 : $prec); 321642262Skato if ($dolist) { 321733021Skato $left = "($left)"; 321833021Skato } 321960472Snyan } 322016359Sasami $right = $self->deparse_binop_right($op, $right, $prec); 322133021Skato return $self->maybe_parens("$left x$eq $right", $cx, $prec); 322260472Snyan} 322316359Sasami 322433021Skatosub range { 322560472Snyan my $self = shift; 322616359Sasami my ($op, $cx, $type) = @_; 322733021Skato my $left = $op->first; 322823447Skato my $right = $left->sibling; 322916359Sasami $left = $self->deparse($left, 9); 323020127Sasami $right = $self->deparse($right, 9); 323120127Sasami return $self->maybe_parens("$left $type $right", $cx, 9); 323220127Sasami} 323320127Sasami 323433021Skatosub pp_flop { 323560472Snyan my $self = shift; 323616359Sasami my($op, $cx) = @_; 323733021Skato my $flip = $op->first; 323860472Snyan my $type = ($flip->flags & OPf_SPECIAL) ? "..." : ".."; 323916359Sasami return $self->range($flip->first, $cx, $type); 324033021Skato} 324160472Snyan 324216359Sasami# one-line while/until is handled in pp_leave 324333021Skato 324423447Skatosub logop { 324516359Sasami my $self = shift; 324633021Skato my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; 324716359Sasami my $left = $op->first; 324883434Simp my $right = $op->first->sibling; 324916359Sasami $blockname &&= $self->keyword($blockname); 325016359Sasami if ($cx < 1 and is_scope($right) and $blockname 325116359Sasami and $self->{'expand'} < 7) 325216359Sasami { # if ($a) {$b} 325316359Sasami $left = $self->deparse($left, 1); 325416359Sasami $right = $self->deparse($right, 0); 325533021Skato return "$blockname ($left) {\n\t$right\n\b}\cK"; 325616359Sasami } elsif ($cx < 1 and $blockname and not $self->{'parens'} 325716359Sasami and $self->{'expand'} < 7) { # $b if $a 325833021Skato $right = $self->deparse($right, 1); 325916359Sasami $left = $self->deparse($left, 1); 326016359Sasami return "$right $blockname $left"; 326116359Sasami } elsif ($cx > $lowprec and $highop) { # $a && $b 326233021Skato $left = $self->deparse_binop_left($op, $left, $highprec); 326317256Sasami $right = $self->deparse_binop_right($op, $right, $highprec); 326417256Sasami return $self->maybe_parens("$left $highop $right", $cx, $highprec); 326517256Sasami } else { # $a and $b 326633021Skato $left = $self->deparse_binop_left($op, $left, $lowprec); 326716359Sasami $right = $self->deparse_binop_right($op, $right, $lowprec); 326860472Snyan return $self->maybe_parens("$left $lowop $right", $cx, $lowprec); 326960472Snyan } 327060472Snyan} 327160472Snyan 327233021Skatosub pp_and { logop(@_, "and", 3, "&&", 11, "if") } 327316359Sasamisub pp_or { logop(@_, "or", 2, "||", 10, "unless") } 327416359Sasamisub pp_dor { logop(@_, "//", 10) } 327516359Sasami 327616359Sasami# xor is syntactically a logop, but it's really a binop (contrary to 327760472Snyan# old versions of opcode.pl). Syntax is what matters here. 327816359Sasamisub pp_xor { logop(@_, "xor", 2, "", 0, "") } 327916359Sasami 328060472Snyansub logassignop { 328116359Sasami my $self = shift; 328216359Sasami my ($op, $cx, $opname) = @_; 328316359Sasami my $left = $op->first; 328416359Sasami my $right = $op->first->sibling->first; # skip sassign 328516359Sasami $left = $self->deparse($left, 7); 328616359Sasami $right = $self->deparse($right, 7); 328716359Sasami return $self->maybe_parens("$left $opname $right", $cx, 7); 328833021Skato} 328933021Skato 329033021Skatosub pp_andassign { logassignop(@_, "&&=") } 329133021Skatosub pp_orassign { logassignop(@_, "||=") } 329216359Sasamisub pp_dorassign { logassignop(@_, "//=") } 329316359Sasami 329416359Sasamimy %cmpchain_cmpops = ( 329516359Sasami eq => ["==", 14], 329616359Sasami i_eq => ["==", 14], 329716359Sasami ne => ["!=", 14], 329816359Sasami i_ne => ["!=", 14], 329916359Sasami seq => ["eq", 14], 330016359Sasami sne => ["ne", 14], 330116359Sasami lt => ["<", 15], 330216359Sasami i_lt => ["<", 15], 330316359Sasami gt => [">", 15], 330416359Sasami i_gt => [">", 15], 330516359Sasami le => ["<=", 15], 330683434Simp i_le => ["<=", 15], 330716359Sasami ge => [">=", 15], 330816359Sasami i_ge => [">=", 15], 330916359Sasami slt => ["lt", 15], 331016359Sasami sgt => ["gt", 15], 331116359Sasami sle => ["le", 15], 331216359Sasami sge => ["ge", 15], 331316359Sasami); 331416359Sasamisub pp_cmpchain_and { 331516359Sasami my($self, $op, $cx) = @_; 331616359Sasami my($prec, $dep); 331716359Sasami while(1) { 331816359Sasami my($thiscmp, $rightcond); 331916359Sasami if($op->name eq "cmpchain_and") { 332033021Skato $thiscmp = $op->first; 332133021Skato $rightcond = $thiscmp->sibling; 332233021Skato } else { 332333021Skato $thiscmp = $op; 332416359Sasami } 332516359Sasami my $thiscmptype = $cmpchain_cmpops{$thiscmp->name} // (return "XXX"); 332645226Skato if(defined $prec) { 332745226Skato $thiscmptype->[1] == $prec or return "XXX"; 332845226Skato $thiscmp->first->name eq "null" && 332945226Skato !($thiscmp->first->flags & OPf_KIDS) 333016359Sasami or return "XXX"; 333116359Sasami } else { 333216359Sasami $prec = $thiscmptype->[1]; 333316359Sasami $dep = $self->deparse($thiscmp->first, $prec); 333416359Sasami } 333516359Sasami $dep .= " ".$thiscmptype->[0]." "; 333616359Sasami my $operand = $thiscmp->last; 333716359Sasami if(defined $rightcond) { 333865568Skato $operand->name eq "cmpchain_dup" or return "XXX"; 333938297Skato $operand = $operand->first; 334067580Sjhb } 334116359Sasami $dep .= $self->deparse($operand, $prec); 334216359Sasami last unless defined $rightcond; 334316359Sasami if($rightcond->name eq "null" && ($rightcond->flags & OPf_KIDS) && 334416359Sasami $rightcond->first->name eq "cmpchain_and") { 334516359Sasami $rightcond = $rightcond->first; 334616359Sasami } 334753373Snyan $op = $rightcond; 334816359Sasami } 334916359Sasami return $self->maybe_parens($dep, $cx, $prec); 335016359Sasami} 335116359Sasami 335216359Sasamisub rv2gv_or_string { 335316359Sasami my($self,$op) = @_; 335416359Sasami if ($op->name eq "gv") { # could be open("open") or open("###") 335516359Sasami my($name,$quoted) = 335637025Skato $self->stash_variable_name("", $self->gv_or_padgv($op)); 335716359Sasami $quoted ? $name : "*$name"; 335837025Skato } 335937025Skato else { 336016359Sasami $self->deparse($op, 6); 336172200Sbmilekic } 336216359Sasami} 336316359Sasami 336416359Sasamisub listop { 336516359Sasami my $self = shift; 336616359Sasami my($op, $cx, $name, $kid, $nollafr) = @_; 336716359Sasami my(@exprs); 336816359Sasami my $parens = ($cx >= 5) || $self->{'parens'}; 336972200Sbmilekic $kid ||= $op->first->sibling; 337016359Sasami # If there are no arguments, add final parentheses (or parenthesize the 337116359Sasami # whole thing if the llafr does not apply) to account for cases like 337243663Skato # (return)+1 or setpgrp()+1. When the llafr does not apply, we use a 337372200Sbmilekic # precedence of 6 (< comma), as "return, 1" does not need parentheses. 337443663Skato if (null $kid) { 337572200Sbmilekic return $nollafr 337616359Sasami ? $self->maybe_parens($self->keyword($name), $cx, 7) 337716359Sasami : $self->keyword($name) . '()' x (7 < $cx); 337816359Sasami } 337916359Sasami my $first; 338016359Sasami my $fullname = $self->keyword($name); 338142262Skato my $proto = prototype("CORE::$name"); 338216359Sasami if ( 338372200Sbmilekic ( (defined $proto && $proto =~ /^;?\*/) 338416359Sasami || $name eq 'select' # select(F) doesn't have a proto 338516359Sasami ) 338616359Sasami && $kid->name eq "rv2gv" 338716359Sasami && !($kid->private & OPpLVAL_INTRO) 338816359Sasami ) { 338972200Sbmilekic $first = $self->rv2gv_or_string($kid->first); 339016359Sasami } 339116359Sasami else { 339216359Sasami $first = $self->deparse($kid, 6); 339316359Sasami } 339416359Sasami if ($name eq "chmod" && $first =~ /^\d+$/) { 339516359Sasami $first = sprintf("%#o", $first); 339616359Sasami } 339716359Sasami $first = "+$first" 339872200Sbmilekic if not $parens and not $nollafr and substr($first, 0, 1) eq "("; 339916359Sasami push @exprs, $first; 340016359Sasami $kid = $kid->sibling; 340172200Sbmilekic if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv" 340225026Skato && !($kid->private & OPpLVAL_INTRO)) { 340325026Skato push @exprs, $first = $self->rv2gv_or_string($kid->first); 340420129Sasami $kid = $kid->sibling; 340525026Skato } 340625026Skato for (; !null($kid); $kid = $kid->sibling) { 340716359Sasami push @exprs, $self->deparse($kid, 6); 340816359Sasami } 340916359Sasami if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) { 341016359Sasami return "$exprs[0] = $fullname" 341116359Sasami . ($parens ? "($exprs[0])" : " $exprs[0]"); 341216359Sasami } 341316359Sasami 341416359Sasami if ($parens && $nollafr) { 341516359Sasami return "($fullname " . join(", ", @exprs) . ")"; 341616359Sasami } elsif ($parens) { 341716359Sasami return "$fullname(" . join(", ", @exprs) . ")"; 341816359Sasami } else { 341916359Sasami return "$fullname " . join(", ", @exprs); 342016359Sasami } 342116359Sasami} 342216359Sasami 342316359Sasamisub pp_bless { listop(@_, "bless") } 342416359Sasamisub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") } 342518846Sasamisub pp_substr { 342618846Sasami my ($self,$op,$cx) = @_; 342716359Sasami if ($op->private & OPpSUBSTR_REPL_FIRST) { 342816359Sasami return 342916359Sasami listop($self, $op, 7, "substr", $op->first->sibling->sibling) 343042262Skato . " = " 343116359Sasami . $self->deparse($op->first->sibling, 7); 343216359Sasami } 343316359Sasami maybe_local(@_, listop(@_, "substr")) 343416359Sasami} 343516359Sasami 343660472Snyansub pp_index { 343760472Snyan # Also handles pp_rindex. 343842262Skato # 343971713Snyan # The body of this function includes an unrolled maybe_targmy(), 344042262Skato # since the two parts of that sub's actions need to have have the 344171713Snyan # '== -1' bit in between 344271713Snyan 344371713Snyan my($self, $op, $cx) = @_; 344442262Skato 344571713Snyan my $lex = ($op->private & OPpTARGET_MY); 344671713Snyan my $bool = ($op->private & OPpTRUEBOOL); 344771713Snyan 344842262Skato my $val = $self->listop($op, ($bool ? 14 : $lex ? 7 : $cx), $op->name); 344942262Skato 345016359Sasami # (index() == -1) has op_eq and op_const optimised away 345116359Sasami if ($bool) { 345216359Sasami $val .= ($op->private & OPpINDEX_BOOLNEG) ? " == -1" : " != -1"; 345316359Sasami $val = "($val)" if ($op->flags & OPf_PARENS); 345416359Sasami } 345516359Sasami if ($lex) { 345642262Skato my $var = $self->padname($op->targ); 345751202Snyan $val = $self->maybe_parens("$var = $val", $cx, 7); 345816359Sasami } 345916359Sasami $val; 346071713Snyan} 346160472Snyan 346216359Sasamisub pp_rindex { pp_index(@_); } 346316359Sasamisub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) } 346416359Sasamisub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") } 346557928Skatosub pp_formline { listop(@_, "formline") } # see also deparse_format 346657928Skatosub pp_crypt { maybe_targmy(@_, \&listop, "crypt") } 346716359Sasamisub pp_unpack { listop(@_, "unpack") } 346816359Sasamisub pp_pack { listop(@_, "pack") } 346916359Sasamisub pp_join { maybe_targmy(@_, \&listop, "join") } 347042262Skatosub pp_splice { listop(@_, "splice") } 347142262Skatosub pp_push { maybe_targmy(@_, \&listop, "push") } 347260472Snyansub pp_unshift { maybe_targmy(@_, \&listop, "unshift") } 347332089Skatosub pp_reverse { listop(@_, "reverse") } 347460472Snyansub pp_warn { listop(@_, "warn") } 347560472Snyansub pp_die { listop(@_, "die") } 347616359Sasamisub pp_return { listop(@_, "return", undef, 1) } # llafr does not apply 347716359Sasamisub pp_open { listop(@_, "open") } 347816359Sasamisub pp_pipe_op { listop(@_, "pipe") } 347916359Sasamisub pp_tie { listop(@_, "tie") } 348016359Sasamisub pp_binmode { listop(@_, "binmode") } 348116359Sasamisub pp_dbmopen { listop(@_, "dbmopen") } 348216359Sasamisub pp_sselect { listop(@_, "select") } 348342262Skatosub pp_select { listop(@_, "select") } 348416359Sasamisub pp_read { listop(@_, "read") } 348516359Sasamisub pp_sysopen { listop(@_, "sysopen") } 348616359Sasamisub pp_sysseek { listop(@_, "sysseek") } 348716359Sasamisub pp_sysread { listop(@_, "sysread") } 348816359Sasamisub pp_syswrite { listop(@_, "syswrite") } 348916359Sasamisub pp_send { listop(@_, "send") } 349016359Sasamisub pp_recv { listop(@_, "recv") } 349116359Sasamisub pp_seek { listop(@_, "seek") } 349216359Sasamisub pp_fcntl { listop(@_, "fcntl") } 349316359Sasamisub pp_ioctl { listop(@_, "ioctl") } 349416359Sasamisub pp_flock { maybe_targmy(@_, \&listop, "flock") } 349516359Sasamisub pp_socket { listop(@_, "socket") } 349616359Sasamisub pp_sockpair { listop(@_, "socketpair") } 349716359Sasamisub pp_bind { listop(@_, "bind") } 349816359Sasamisub pp_connect { listop(@_, "connect") } 349916359Sasamisub pp_listen { listop(@_, "listen") } 350016359Sasamisub pp_accept { listop(@_, "accept") } 350116359Sasamisub pp_shutdown { listop(@_, "shutdown") } 350216359Sasamisub pp_gsockopt { listop(@_, "getsockopt") } 350316359Sasamisub pp_ssockopt { listop(@_, "setsockopt") } 350416359Sasamisub pp_chown { maybe_targmy(@_, \&listop, "chown") } 350516359Sasamisub pp_unlink { maybe_targmy(@_, \&listop, "unlink") } 350616359Sasamisub pp_chmod { maybe_targmy(@_, \&listop, "chmod") } 350716359Sasamisub pp_utime { maybe_targmy(@_, \&listop, "utime") } 350816359Sasamisub pp_rename { maybe_targmy(@_, \&listop, "rename") } 350916359Sasamisub pp_link { maybe_targmy(@_, \&listop, "link") } 351016359Sasamisub pp_symlink { maybe_targmy(@_, \&listop, "symlink") } 351116359Sasamisub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") } 351216359Sasamisub pp_open_dir { listop(@_, "opendir") } 351316359Sasamisub pp_seekdir { listop(@_, "seekdir") } 351416359Sasamisub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") } 351516359Sasamisub pp_system { maybe_targmy(@_, \&indirop, "system") } 351616359Sasamisub pp_exec { maybe_targmy(@_, \&indirop, "exec") } 351716359Sasamisub pp_kill { maybe_targmy(@_, \&listop, "kill") } 351822120Skatosub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") } 351922120Skatosub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") } 352022120Skatosub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") } 352122120Skatosub pp_shmget { listop(@_, "shmget") } 352222120Skatosub pp_shmctl { listop(@_, "shmctl") } 352322120Skatosub pp_shmread { listop(@_, "shmread") } 352422120Skatosub pp_shmwrite { listop(@_, "shmwrite") } 352522120Skatosub pp_msgget { listop(@_, "msgget") } 352622120Skatosub pp_msgctl { listop(@_, "msgctl") } 352760472Snyansub pp_msgsnd { listop(@_, "msgsnd") } 352816359Sasamisub pp_msgrcv { listop(@_, "msgrcv") } 352916359Sasamisub pp_semget { listop(@_, "semget") } 353016359Sasamisub pp_semctl { listop(@_, "semctl") } 353116359Sasamisub pp_semop { listop(@_, "semop") } 353216359Sasamisub pp_ghbyaddr { listop(@_, "gethostbyaddr") } 353365611Skatosub pp_gnbyaddr { listop(@_, "getnetbyaddr") } 353465611Skatosub pp_gpbynumber { listop(@_, "getprotobynumber") } 353565611Skatosub pp_gsbyname { listop(@_, "getservbyname") } 353665611Skatosub pp_gsbyport { listop(@_, "getservbyport") } 353765611Skatosub pp_syscall { listop(@_, "syscall") } 353843663Skato 353916359Sasamisub pp_glob { 354016359Sasami my $self = shift; 354142262Skato my($op, $cx) = @_; 354260472Snyan my $kid = $op->first->sibling; # skip pushmark 354342262Skato my $keyword = 354416359Sasami $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob'); 354516359Sasami my $text = $self->deparse($kid, $cx); 354660472Snyan return $cx >= 5 || $self->{'parens'} 354718846Sasami ? "$keyword($text)" 354818846Sasami : "$keyword $text"; 354918846Sasami} 355018846Sasami 355118846Sasami# Truncate is special because OPf_SPECIAL makes a bareword first arg 355218846Sasami# be a filehandle. This could probably be better fixed in the core 355318846Sasami# by moving the GV lookup into ck_truc. 355460472Snyan 355560472Snyansub pp_truncate { 355642262Skato my $self = shift; 355760472Snyan my($op, $cx) = @_; 355860472Snyan my(@exprs); 355916359Sasami my $parens = ($cx >= 5) || $self->{'parens'}; 356027479Skato my $kid = $op->first->sibling; 356160472Snyan my $fh; 356242262Skato if ($op->flags & OPf_SPECIAL) { 356342262Skato # $kid is an OP_CONST 356442262Skato $fh = $self->const_sv($kid)->PV; 356527479Skato } else { 356616359Sasami $fh = $self->deparse($kid, 6); 356732546Skato $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "("; 356832546Skato } 356932546Skato my $len = $self->deparse($kid->sibling, 6); 357060472Snyan my $name = $self->keyword('truncate'); 357127479Skato if ($parens) { 357260472Snyan return "$name($fh, $len)"; 357360472Snyan } else { 357460472Snyan return "$name $fh, $len"; 357527479Skato } 357660472Snyan} 357720127Sasami 357820127Sasamisub indirop { 357920127Sasami my $self = shift; 358020127Sasami my($op, $cx, $name) = @_; 358120127Sasami my($expr, @exprs); 358220127Sasami my $firstkid = my $kid = $op->first->sibling; 358320127Sasami my $indir = ""; 358420127Sasami if ($op->flags & OPf_STACKED) { 358516359Sasami $indir = $kid; 358620127Sasami $indir = $indir->first; # skip rv2gv 358720127Sasami if (is_scope($indir)) { 358820127Sasami $indir = "{" . $self->deparse($indir, 0) . "}"; 358920127Sasami $indir = "{;}" if $indir eq "{}"; 359023447Skato } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) { 359142262Skato $indir = $self->const_sv($indir)->PV; 359223447Skato } else { 359323447Skato $indir = $self->deparse($indir, 24); 359460472Snyan } 359560472Snyan $indir = $indir . " "; 359620127Sasami $kid = $kid->sibling; 359727479Skato } 359860472Snyan if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) { 359960472Snyan $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} ' 360060472Snyan : '{$a <=> $b} '; 360127479Skato } 360260472Snyan elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) { 360320127Sasami $indir = '{$b cmp $a} '; 360416359Sasami } 360527479Skato for (; !null($kid); $kid = $kid->sibling) { 360616359Sasami $expr = $self->deparse($kid, !$indir && $kid == $firstkid && $name eq "sort" && $firstkid->name eq "entersub" ? 16 : 6); 360716359Sasami push @exprs, $expr; 360816359Sasami } 360916359Sasami my $name2; 361016359Sasami if ($name eq "sort" && $op->private & OPpSORT_REVERSE) { 361116359Sasami $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort'); 361216359Sasami } 361342262Skato else { $name2 = $self->keyword($name) } 361442262Skato if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) { 361542262Skato return "$exprs[0] = $name2 $indir $exprs[0]"; 361642262Skato } 361742262Skato 361842262Skato my $args = $indir . join(", ", @exprs); 361916359Sasami if ($indir ne "" && $name eq "sort") { 362016359Sasami # We don't want to say "sort(f 1, 2, 3)", since perl -w will 362116359Sasami # give bareword warnings in that case. Therefore if context 362242262Skato # requires, we'll put parens around the outside "(sort f 1, 2, 362316359Sasami # 3)". Unfortunately, we'll currently think the parens are 362416359Sasami # necessary more often that they really are, because we don't 362516359Sasami # distinguish which side of an assignment we're on. 362660472Snyan if ($cx >= 5) { 362760472Snyan return "($name2 $args)"; 362860472Snyan } else { 362960472Snyan return "$name2 $args"; 363016359Sasami } 363116359Sasami } elsif ( 363232546Skato !$indir && $name eq "sort" 363360472Snyan && !null($op->first->sibling) 363460472Snyan && $op->first->sibling->name eq 'entersub' 363560472Snyan ) { 363627479Skato # We cannot say sort foo(bar), as foo will be interpreted as a 363760472Snyan # comparison routine. We have to say sort(...) in that case. 363860472Snyan return "$name2($args)"; 363960472Snyan } else { 364027479Skato return length $args 364127479Skato ? $self->maybe_parens_func($name2, $args, $cx, 5) 364227479Skato : $name2 . '()' x (7 < $cx); 364360472Snyan } 364460472Snyan 364560472Snyan} 364627479Skato 364760472Snyansub pp_prtf { indirop(@_, "printf") } 364816359Sasamisub pp_print { indirop(@_, "print") } 364927479Skatosub pp_say { indirop(@_, "say") } 365042262Skatosub pp_sort { indirop(@_, "sort") } 365160472Snyan 365242262Skatosub mapop { 365360472Snyan my $self = shift; 365427479Skato my($op, $cx, $name) = @_; 365516359Sasami my($expr, @exprs); 365616359Sasami my $kid = $op->first; # this is the (map|grep)start 365716359Sasami $kid = $kid->first->sibling; # skip a pushmark 365816359Sasami my $code = $kid->first; # skip a null 365916359Sasami if (is_scope $code) { 366016359Sasami $code = "{" . $self->deparse($code, 0) . "} "; 366116359Sasami } else { 366216359Sasami $code = $self->deparse($code, 24); 366316359Sasami $code .= ", " if !null($kid->sibling); 366416359Sasami } 366572200Sbmilekic $kid = $kid->sibling; 366616359Sasami for (; !null($kid); $kid = $kid->sibling) { 366720127Sasami $expr = $self->deparse($kid, 6); 366843663Skato push @exprs, $expr if defined $expr; 366943663Skato } 367043663Skato return $self->maybe_parens_func($self->keyword($name), 367143663Skato $code . join(", ", @exprs), $cx, 5); 367216359Sasami} 367316359Sasami 367416359Sasamisub pp_mapwhile { mapop(@_, "map") } 367565611Skatosub pp_grepwhile { mapop(@_, "grep") } 367671713Snyansub pp_mapstart { baseop(@_, "map") } 367771713Snyansub pp_grepstart { baseop(@_, "grep") } 367865611Skato 367943663Skatomy %uses_intro; 368043663SkatoBEGIN { 368143663Skato @uses_intro{ 368243663Skato eval { require B::Op_private } 368343663Skato ? @{$B::Op_private::ops_using{OPpLVAL_INTRO}} 368443663Skato : qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice 368543663Skato hslice delete padsv padav padhv enteriter entersub padrange 368643663Skato pushmark cond_expr refassign list) 368743663Skato } = (); 368843663Skato delete @uses_intro{qw( lvref lvrefslice lvavref entersub )}; 368943663Skato} 369043663Skato 369143663Skato 369243663Skato# Look for a my/state attribute declaration in a list or ex-list. 369343663Skato# Returns undef if not found, 'my($x, @a) :Foo(bar)' etc otherwise. 369443663Skato# 369543663Skato# There are three basic tree structs that are expected: 369643663Skato# 369743663Skato# my $x :foo; 369843663Skato# <1> ex-list vK/LVINTRO ->c 369943663Skato# <0> ex-pushmark v ->3 370043663Skato# <1> entersub[t2] vKRS*/TARG ->b 370143663Skato# .... 370265611Skato# <0> padsv[$x:64,65] vM/LVINTRO ->c 370372200Sbmilekic# 370443663Skato# my @a :foo; 370565611Skato# my %h :foo; 370643663Skato# 370743663Skato# <1> ex-list vK ->c 370843663Skato# <0> ex-pushmark v ->3 370943663Skato# <0> padav[@a:64,65] vM/LVINTRO ->4 371043663Skato# <1> entersub[t2] vKRS*/TARG ->c 371143663Skato# .... 371265611Skato# 371372200Sbmilekic# my ($x,@a,%h) :foo; 371443663Skato# 371565611Skato# <;> nextstate(main 64 -e:1) v:{ ->3 371643663Skato# <@> list vKP ->w 371743663Skato# <0> pushmark vM/LVINTRO ->4 371843663Skato# <0> padsv[$x:64,65] vM/LVINTRO ->5 371943663Skato# <0> padav[@a:64,65] vM/LVINTRO ->6 372043663Skato# <0> padhv[%h:64,65] vM/LVINTRO ->7 372143663Skato# <1> entersub[t4] vKRS*/TARG ->f 372243663Skato# .... 372343663Skato# <1> entersub[t5] vKRS*/TARG ->n 372443663Skato# .... 372543663Skato# <1> entersub[t6] vKRS*/TARG ->v 372643663Skato# .... 372743663Skato# where the entersub in all cases looks like 372843663Skato# <1> entersub[t2] vKRS*/TARG ->c 372943663Skato# <0> pushmark s ->5 373043663Skato# <$> const[PV "attributes"] sM ->6 373172200Sbmilekic# <$> const[PV "main"] sM ->7 373243663Skato# <1> srefgen sKM/1 ->9 373343663Skato# <1> ex-list lKRM ->8 373443663Skato# <0> padsv[@a:64,65] sRM ->8 373543663Skato# <$> const[PV "foo"] sM ->a 373643663Skato# <.> method_named[PV "import"] ->b 373743663Skato 373843663Skatosub maybe_var_attr { 373943663Skato my ($self, $op, $cx) = @_; 374043663Skato 374143663Skato my $kid = $op->first->sibling; # skip pushmark 374243663Skato return if class($kid) eq 'NULL'; 374343663Skato 374443663Skato my $lop; 374543663Skato my $type; 374643663Skato 374743663Skato # Extract out all the pad ops and entersub ops into 374843663Skato # @padops and @entersubops. Return if anything else seen. 374943663Skato # Also determine what class (if any) all the pad vars belong to 375043663Skato my $class; 375143663Skato my $decl; # 'my' or 'state' 375243663Skato my (@padops, @entersubops); 375316359Sasami for ($lop = $kid; !null($lop); $lop = $lop->sibling) { 375416359Sasami my $lopname = $lop->name; 375516359Sasami my $loppriv = $lop->private; 375616359Sasami if ($lopname =~ /^pad[sah]v$/) { 375716359Sasami return unless $loppriv & OPpLVAL_INTRO; 375816359Sasami 375916359Sasami my $padname = $self->padname_sv($lop->targ); 376016359Sasami my $thisclass = ($padname->FLAGS & PADNAMEf_TYPED) 376116359Sasami ? $padname->SvSTASH->NAME : 'main'; 376216359Sasami 376357928Skato # all pad vars must be in the same class 376457928Skato $class //= $thisclass; 376516359Sasami return unless $thisclass eq $class; 376672200Sbmilekic 376716359Sasami # all pad vars must be the same sort of declaration 376816359Sasami # (all my, all state, etc) 376916359Sasami my $this = ($loppriv & OPpPAD_STATE) ? 'state' : 'my'; 377016359Sasami if (defined $decl) { 377116359Sasami return unless $this eq $decl; 377216359Sasami } 377353884Snyan $decl = $this; 377453884Snyan 377553884Snyan push @padops, $lop; 377653884Snyan } 377753884Snyan elsif ($lopname eq 'entersub') { 377853884Snyan push @entersubops, $lop; 377953884Snyan } 378053884Snyan else { 378153884Snyan return; 378216359Sasami } 378316359Sasami } 378453884Snyan 378516359Sasami return unless @padops && @padops == @entersubops; 378616359Sasami 378716359Sasami # there should be a balance: each padop has a corresponding 378853884Snyan # 'attributes'->import() method call, in the same order. 378953884Snyan 379053884Snyan my @varnames; 379153884Snyan my $attr_text; 379253884Snyan 379353884Snyan for my $i (0..$#padops) { 379453884Snyan my $padop = $padops[$i]; 379553884Snyan my $esop = $entersubops[$i]; 379653884Snyan 379753884Snyan push @varnames, $self->padname($padop->targ); 379853884Snyan 379916359Sasami return unless ($esop->flags & OPf_KIDS); 380020127Sasami 380120127Sasami my $kid = $esop->first; 380253884Snyan return unless $kid->type == OP_PUSHMARK; 380316359Sasami 380416359Sasami $kid = $kid->sibling; 380572200Sbmilekic return unless $$kid && $kid->type == OP_CONST; 380616359Sasami return unless $self->const_sv($kid)->PV eq 'attributes'; 380732089Skato 380816359Sasami $kid = $kid->sibling; 380916359Sasami return unless $$kid && $kid->type == OP_CONST; # __PACKAGE__ 381016359Sasami 381116359Sasami $kid = $kid->sibling; 381216359Sasami return unless $$kid 381316359Sasami && $kid->name eq "srefgen" 381416359Sasami && ($kid->flags & OPf_KIDS) 381516359Sasami && ($kid->first->flags & OPf_KIDS) 381616359Sasami && $kid->first->first->name =~ /^pad[sah]v$/ 381716359Sasami && $kid->first->first->targ == $padop->targ; 381860472Snyan 381960472Snyan $kid = $kid->sibling; 382060472Snyan my @attr; 382116359Sasami while ($$kid) { 382242262Skato last if ($kid->type != OP_CONST); 382316359Sasami push @attr, $self->const_sv($kid)->PV; 382416359Sasami $kid = $kid->sibling; 382572200Sbmilekic } 382616359Sasami return unless @attr; 382716359Sasami my $thisattr = ":" . join(' ', @attr); 382816359Sasami $attr_text //= $thisattr; 382916359Sasami # all import calls must have the same list of attributes 383016359Sasami return unless $attr_text eq $thisattr; 383116359Sasami 383216359Sasami return unless $kid->name eq 'method_named'; 383316359Sasami return unless $self->meth_sv($kid)->PV eq 'import'; 383416359Sasami 383516359Sasami $kid = $kid->sibling; 383616359Sasami return if $$kid; 383772200Sbmilekic } 383816359Sasami 383916359Sasami my $res = $decl; 384016359Sasami $res .= " $class " if $class ne 'main'; 384116359Sasami $res .= 384260472Snyan (@varnames > 1) 384360472Snyan ? "(" . join(', ', @varnames) . ')' 384460472Snyan : " $varnames[0]"; 384516359Sasami 384642262Skato return "$res $attr_text"; 384716359Sasami} 384816359Sasami 384972200Sbmilekic 385016359Sasamisub pp_list { 385116359Sasami my $self = shift; 385216359Sasami my($op, $cx) = @_; 385316359Sasami 385416359Sasami { 385516359Sasami # might be my ($s,@a,%h) :Foo(bar); 385616359Sasami my $my_attr = maybe_var_attr($self, $op, $cx); 385716359Sasami return $my_attr if defined $my_attr; 385816359Sasami } 385916359Sasami 386016359Sasami my($expr, @exprs); 386172200Sbmilekic my $kid = $op->first->sibling; # skip pushmark 386216359Sasami return '' if class($kid) eq 'NULL'; 386316359Sasami my $lop; 386416359Sasami my $local = "either"; # could be local(...), my(...), state(...) or our(...) 386572200Sbmilekic my $type; 386616359Sasami for ($lop = $kid; !null($lop); $lop = $lop->sibling) { 386716359Sasami my $lopname = $lop->name; 386872200Sbmilekic my $loppriv = $lop->private; 386916359Sasami my $newtype; 387016359Sasami if ($lopname =~ /^pad[ash]v$/ && $loppriv & OPpLVAL_INTRO) { 387116359Sasami if ($loppriv & OPpPAD_STATE) { # state() 387216359Sasami ($local = "", last) if $local !~ /^(?:either|state)$/; 387316359Sasami $local = "state"; 387451654Sphk } else { # my() 387516359Sasami ($local = "", last) if $local !~ /^(?:either|my)$/; 387616359Sasami $local = "my"; 387716359Sasami } 387816359Sasami my $padname = $self->padname_sv($lop->targ); 387942262Skato if ($padname->FLAGS & PADNAMEf_TYPED) { 388042262Skato $newtype = $padname->SvSTASH->NAME; 388142262Skato } 388216359Sasami } elsif ($lopname eq 'padsv_store') { 388316359Sasami # don't interpret as my (list) if it has an implicit assign 388457928Skato $local = ""; 388516359Sasami } elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/ 388672200Sbmilekic && $loppriv & OPpOUR_INTRO 388760472Snyan or $lopname eq "null" && class($lop) eq 'UNOP' 388842262Skato && $lop->first->name eq "gvsv" 388960472Snyan && $lop->first->private & OPpOUR_INTRO) { # our() 389042262Skato my $newlocal = "local " x !!($loppriv & OPpLVAL_INTRO) . "our"; 389120129Sasami ($local = "", last) 389222120Skato if $local ne 'either' && $local ne $newlocal; 389322120Skato $local = $newlocal; 389422120Skato my $funny = !$1 || $1 eq 's' ? '$' : $1 eq 'a' ? '@' : '%'; 389522120Skato if (my $t = $self->find_our_type( 389660472Snyan $funny . $self->gv_or_padgv($lop->first)->NAME 389760472Snyan )) { 389842262Skato $newtype = $t; 389960472Snyan } 390060472Snyan } elsif ($lopname ne 'undef' 390160472Snyan and !($loppriv & OPpLVAL_INTRO) 390260472Snyan || !exists $uses_intro{$lopname eq 'null' 390360472Snyan ? substr B::ppname($lop->targ), 3 390442262Skato : $lopname}) 390516359Sasami { 390616359Sasami $local = ""; # or not 390716359Sasami last; 390816359Sasami } elsif ($lopname ne "undef") 390916359Sasami { 391016359Sasami # local() 391116359Sasami ($local = "", last) if $local !~ /^(?:either|local)$/; 391216359Sasami $local = "local"; 391360472Snyan } 391460472Snyan if (defined $type && defined $newtype && $newtype ne $type) { 391560472Snyan $local = ''; 391660472Snyan last; 391760472Snyan } 391860472Snyan $type = $newtype; 391920129Sasami } 392022120Skato $local = "" if $local eq "either"; # no point if it's all undefs 392122120Skato $local &&= join ' ', map $self->keyword($_), split / /, $local; 392222120Skato $local .= " $type " if $local && length $type; 392322120Skato return $self->deparse($kid, $cx) if null $kid->sibling and not $local; 392460472Snyan for (; !null($kid); $kid = $kid->sibling) { 392560472Snyan if ($local) { 392642262Skato if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") { 392760472Snyan $lop = $kid->first; 392842262Skato } else { 392916359Sasami $lop = $kid; 393016359Sasami } 393116359Sasami $self->{'avoid_local'}{$$lop}++; 393272200Sbmilekic $expr = $self->deparse($kid, 6); 393316359Sasami delete $self->{'avoid_local'}{$$lop}; 393416359Sasami } else { 393516359Sasami $expr = $self->deparse($kid, 6); 393616359Sasami } 393716359Sasami push @exprs, $expr; 393816359Sasami } 393916359Sasami if ($local) { 394016359Sasami if (@exprs == 1 && ($local eq 'state' || $local eq 'CORE::state')) { 394116359Sasami # 'state @a = ...' is legal, while 'state(@a) = ...' currently isn't 394216359Sasami return "$local $exprs[0]"; 394316359Sasami } 394416359Sasami return "$local(" . join(", ", @exprs) . ")"; 394516359Sasami } else { 394616359Sasami return $self->maybe_parens( join(", ", @exprs), $cx, 6); 394716359Sasami } 394816359Sasami} 394916359Sasami 395016359Sasamisub is_ifelse_cont { 395116359Sasami my $op = shift; 395216359Sasami return ($op->name eq "null" and class($op) eq "UNOP" 395316359Sasami and $op->first->name =~ /^(and|cond_expr)$/ 395416359Sasami and is_scope($op->first->first->sibling)); 395516359Sasami} 395616359Sasami 395716359Sasamisub pp_cond_expr { 395816359Sasami my $self = shift; 395916359Sasami my($op, $cx) = @_; 396016359Sasami my $cond = $op->first; 396116359Sasami my $true = $cond->sibling; 396216359Sasami my $false = $true->sibling; 396316359Sasami my $cuddle = $self->{'cuddle'}; 396416359Sasami unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and 396516359Sasami (is_scope($false) || is_ifelse_cont($false)) 396616359Sasami and $self->{'expand'} < 7) { 396716359Sasami $cond = $self->deparse($cond, 8); 396816359Sasami $true = $self->deparse($true, 6); 396916359Sasami $false = $self->deparse($false, 8); 397016359Sasami return $self->maybe_parens("$cond ? $true : $false", $cx, 8); 397116359Sasami } 397216359Sasami 397316359Sasami $cond = $self->deparse($cond, 1); 397416359Sasami $true = $self->deparse($true, 0); 397572200Sbmilekic my $head = $self->keyword("if") . " ($cond) {\n\t$true\n\b}"; 397616359Sasami my @elsifs; 397716359Sasami my $elsif; 397816359Sasami while (!null($false) and is_ifelse_cont($false)) { 397916359Sasami my $newop = $false->first; 398016359Sasami my $newcond = $newop->first; 398116359Sasami my $newtrue = $newcond->sibling; 398216359Sasami $false = $newtrue->sibling; # last in chain is OP_AND => no else 398316359Sasami if ($newcond->name eq "lineseq") 398416359Sasami { 398516359Sasami # lineseq to ensure correct line numbers in elsif() 398616359Sasami # Bug #37302 fixed by change #33710. 398716359Sasami $newcond = $newcond->first->sibling; 398872200Sbmilekic } 398916359Sasami $newcond = $self->deparse($newcond, 1); 399016359Sasami $newtrue = $self->deparse($newtrue, 0); 399116359Sasami $elsif ||= $self->keyword("elsif"); 399216359Sasami push @elsifs, "$elsif ($newcond) {\n\t$newtrue\n\b}"; 399316359Sasami } 399416359Sasami if (!null($false)) { 399516359Sasami $false = $cuddle . $self->keyword("else") . " {\n\t" . 399616359Sasami $self->deparse($false, 0) . "\n\b}\cK"; 399716359Sasami } else { 399816359Sasami $false = "\cK"; 399916359Sasami } 400016359Sasami return $head . join($cuddle, "", @elsifs) . $false; 400116359Sasami} 400216359Sasami 400316359Sasamisub pp_once { 400429715Skato my ($self, $op, $cx) = @_; 400516359Sasami my $cond = $op->first; 400616359Sasami my $true = $cond->sibling; 400753373Snyan 400816359Sasami my $ret = $self->deparse($true, $cx); 400916359Sasami $ret =~ s/^(\(?)\$/$1 . $self->keyword("state") . ' $'/e; 401016359Sasami $ret; 401116359Sasami} 401216359Sasami 401316359Sasamisub loop_common { 401416359Sasami my $self = shift; 401516359Sasami my($op, $cx, $init) = @_; 401616359Sasami my $enter = $op->first; 401716359Sasami my $kid = $enter->sibling; 401816359Sasami local(@$self{qw'curstash warnings hints hinthash'}) 401916359Sasami = @$self{qw'curstash warnings hints hinthash'}; 402029715Skato my $head = ""; 402129715Skato my $bare = 0; 402216359Sasami my $body; 402316359Sasami my $cond = undef; 402416359Sasami my $name; 402516359Sasami if ($kid->name eq "lineseq") { # bare or infinite loop 402629715Skato if ($kid->last->name eq "unstack") { # infinite 402716359Sasami $head = "while (1) "; # Can't use for(;;) if there's a continue 402816359Sasami $cond = ""; 402916359Sasami } else { 403016359Sasami $bare = 1; 403116359Sasami } 403216359Sasami $body = $kid; 403316359Sasami } elsif ($enter->name eq "enteriter") { # foreach 403416359Sasami my $ary = $enter->first->sibling; # first was pushmark 403516359Sasami my $var = $ary->sibling; 403616359Sasami if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) { 403729715Skato # "reverse" was optimised away 403816359Sasami $ary = listop($self, $ary->first->sibling, 1, 'reverse'); 403916359Sasami } elsif ($enter->flags & OPf_STACKED 404016359Sasami and not null $ary->first->sibling->sibling) 404116359Sasami { 404216359Sasami $ary = $self->deparse($ary->first->sibling, 9) . " .. " . 404353373Snyan $self->deparse($ary->first->sibling->sibling, 9); 404416359Sasami } else { 404516359Sasami $ary = $self->deparse($ary, 1); 404616359Sasami } 404772200Sbmilekic 404816359Sasami if ($enter->flags & OPf_PARENS) { 404972200Sbmilekic # for my ($x, $y, ...) ... 405016359Sasami # for my ($foo, $bar) () stores the count (less 1) in the targ of 405116359Sasami # the ITER op. For the degenerate case of 1 var ($x), the 405216359Sasami # TARG is zero, so it works anyway 405316359Sasami my $iter_targ = $kid->first->first->targ; 405416359Sasami my @vars; 405516359Sasami my $targ = $enter->targ; 405616359Sasami while ($iter_targ-- >= 0) { 405716359Sasami push @vars, $self->padname_sv($targ)->PVX; 405816359Sasami ++$targ; 405953373Snyan } 406016359Sasami $var = 'my (' . join(', ', @vars) . ')'; 406116359Sasami } elsif (null $var) { 406216359Sasami $var = $self->pp_padsv($enter, 1, 1); 406316359Sasami } elsif ($var->name eq "rv2gv") { 406416359Sasami $var = $self->pp_rv2sv($var, 1); 406516359Sasami if ($enter->private & OPpOUR_INTRO) { 406616359Sasami # our declarations don't have package names 406716359Sasami $var =~ s/^(.).*::/$1/; 406816359Sasami $var = "our $var"; 406916359Sasami } 407016359Sasami } elsif ($var->name eq "gv") { 407172200Sbmilekic $var = "\$" . $self->deparse($var, 1); 407216359Sasami } else { 407316359Sasami $var = $self->deparse($var, 1); 407472200Sbmilekic } 407516359Sasami $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER 407616359Sasami if (!is_state $body->first and $body->first->name !~ /^(?:stub|leave|scope)$/) { 407716359Sasami confess unless $var eq '$_'; 407816359Sasami $body = $body->first; 407916359Sasami return $self->deparse($body, 2) . " " 408016359Sasami . $self->keyword("foreach") . " ($ary)"; 408116359Sasami } 408216359Sasami $head = "foreach $var ($ary) "; 408316359Sasami } elsif ($kid->name eq "null") { # while/until 408416359Sasami $kid = $kid->first; 408516359Sasami $name = {"and" => "while", "or" => "until"}->{$kid->name}; 408616359Sasami $cond = $kid->first; 408716359Sasami $body = $kid->first->sibling; 408816359Sasami } elsif ($kid->name eq "stub") { # bare and empty 408916359Sasami return "{;}"; # {} could be a hashref 409016359Sasami } 409116359Sasami # If there isn't a continue block, then the next pointer for the loop 409216359Sasami # will point to the unstack, which is kid's last child, except 409316359Sasami # in a bare loop, when it will point to the leaveloop. When neither of 409416359Sasami # these conditions hold, then the second-to-last child is the continue 409516359Sasami # block (or the last in a bare loop). 409616359Sasami my $cont_start = $enter->nextop; 409716359Sasami my $cont; 409816359Sasami my $precond; 409916359Sasami my $postcond; 410016359Sasami if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) { 410116359Sasami if ($bare) { 410216359Sasami $cont = $body->last; 410316359Sasami } else { 410416359Sasami $cont = $body->first; 410516359Sasami while (!null($cont->sibling->sibling)) { 410616359Sasami $cont = $cont->sibling; 410716359Sasami } 410816359Sasami } 410916359Sasami my $state = $body->first; 411016359Sasami my $cuddle = $self->{'cuddle'}; 411116359Sasami my @states; 411216359Sasami for (; $$state != $$cont; $state = $state->sibling) { 411316359Sasami push @states, $state; 411416359Sasami } 411516359Sasami $body = $self->lineseq(undef, 0, @states); 411616359Sasami if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) { 411716359Sasami $precond = "for ($init; "; 411816359Sasami $postcond = "; " . $self->deparse($cont, 1) .") "; 411916359Sasami $cont = "\cK"; 412016359Sasami } else { 412116359Sasami $cont = $cuddle . "continue {\n\t" . 412216359Sasami $self->deparse($cont, 0) . "\n\b}\cK"; 412316359Sasami } 412416359Sasami } else { 412516359Sasami return "" if !defined $body; 412616359Sasami if (length $init) { 412716359Sasami $precond = "for ($init; "; 412816359Sasami $postcond = ";) "; 412916359Sasami } 413016359Sasami $cont = "\cK"; 413116359Sasami $body = $self->deparse($body, 0); 413216359Sasami } 413316359Sasami if ($precond) { # for(;;) 413416359Sasami $cond &&= $name eq 'until' 413516359Sasami ? listop($self, undef, 1, "not", $cond->first) 413616359Sasami : $self->deparse($cond, 1); 413716359Sasami $head = "$precond$cond$postcond"; 413833322Sphk } 413916359Sasami if ($name && !$head) { 414016359Sasami ref $cond and $cond = $self->deparse($cond, 1); 414116359Sasami $head = "$name ($cond) "; 414216359Sasami } 414316359Sasami $head =~ s/^(for(?:each)?|while|until)/$self->keyword($1)/e; 414449558Sphk $body =~ s/;?$/;\n/; 414516359Sasami 414616359Sasami return $head . "{\n\t" . $body . "\b}" . $cont; 414716359Sasami} 414816359Sasami 414916359Sasamisub pp_leaveloop { shift->loop_common(@_, "") } 415016359Sasami 415116359Sasamisub for_loop { 415216359Sasami my $self = shift; 415316359Sasami my($op, $cx) = @_; 415466250Skato my $init = $self->deparse($op, 1); 415526439Skato my $s = $op->sibling; 415666250Skato my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling; 415745783Skato return $self->loop_common($ll, $cx, $init); 415845783Skato} 415945783Skato 416016359Sasamisub pp_leavetry { 416166250Skato my $self = shift; 416266250Skato return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}"; 416366250Skato} 416466250Skato 416566250Skatosub pp_leavetrycatch_with_finally { 416666250Skato my $self = shift; 416742405Skato my ($op, $finallyop) = @_; 416842405Skato 416966250Skato # Expect that the first three kids should be (entertrycatch, poptry, catch) 417042405Skato my $entertrycatch = $op->first; 417146871Skato $entertrycatch->name eq "entertrycatch" or die "Expected entertrycatch as first child of leavetrycatch"; 417246871Skato 417342405Skato my $tryblock = $entertrycatch->sibling; 417485149Snyan $tryblock->name eq "poptry" or die "Expected poptry as second child of leavetrycatch"; 417555900Skato 417655900Skato my $catch = $tryblock->sibling; 417751202Snyan $catch->name eq "catch" or die "Expected catch as third child of leavetrycatch"; 417851202Snyan 417946871Skato my $catchblock = $catch->first->sibling; 418046871Skato my $name = $catchblock->name; 418146871Skato unless ($name eq "scope" || $name eq "leave") { 418245783Skato die "Expected scope or leave as second child of catch, got $name instead"; 418345783Skato } 418416359Sasami 418545783Skato my $trycode = scopeop(0, $self, $tryblock); 418645783Skato my $catchvar = $self->padname($catch->targ); 418716359Sasami my $catchcode = $name eq 'scope' ? scopeop(0, $self, $catchblock) 418816359Sasami : scopeop(1, $self, $catchblock); 418916359Sasami 419016359Sasami my $finallycode = ""; 419116359Sasami if($finallyop) { 419216359Sasami my $body = $self->deparse($finallyop->first->first); 419316359Sasami $finallycode = "\nfinally {\n\t$body\n\b}"; 419416359Sasami } 419516359Sasami 419645783Skato return "try {\n\t$trycode\n\b}\n" . 419716359Sasami "catch($catchvar) {\n\t$catchcode\n\b}$finallycode\cK"; 419816359Sasami} 419916359Sasami 420016359Sasamisub pp_leavetrycatch { 420166250Skato my $self = shift; 420266250Skato my ($op, @args) = @_; 420326439Skato return $self->pp_leavetrycatch_with_finally($op, undef, @args); 420426439Skato} 420526439Skato 420626439Skatosub _op_is_or_was { 420726439Skato my ($op, $expect_type) = @_; 420826439Skato my $type = $op->type; 420926439Skato return($type == $expect_type 421026439Skato || ($type == OP_NULL && $op->targ == $expect_type)); 421126439Skato} 421226439Skato 421326439Skatosub pp_null { 421426439Skato my($self, $op, $cx) = @_; 421526439Skato 421626439Skato # might be 'my $s :Foo(bar);' 421726439Skato if ($op->targ == OP_LIST) { 421826439Skato my $my_attr = maybe_var_attr($self, $op, $cx); 421926439Skato return $my_attr if defined $my_attr; 422026439Skato } 422126439Skato 422226439Skato if (class($op) eq "OP") { 422326439Skato # old value is lost 422426439Skato return $self->{'ex_const'} if $op->targ == OP_CONST; 422526439Skato } elsif (class ($op) eq "COP") { 422626439Skato return &pp_nextstate; 422726439Skato } elsif ($op->first->name eq 'pushmark' 422826439Skato or $op->first->name eq 'null' 422926439Skato && $op->first->targ == OP_PUSHMARK 423026439Skato && _op_is_or_was($op, OP_LIST)) { 423126439Skato return $self->pp_list($op, $cx); 423253373Snyan } elsif ($op->first->name eq "enter") { 423326439Skato return $self->pp_leave($op, $cx); 423426439Skato } elsif ($op->first->name eq "leave") { 423526439Skato return $self->pp_leave($op->first, $cx); 423658888Skato } elsif ($op->first->name eq "scope") { 423726439Skato return $self->pp_scope($op->first, $cx); 423826439Skato } elsif ($op->targ == OP_STRINGIFY) { 423966250Skato return $self->dquote($op, $cx); 424066250Skato } elsif ($op->targ == OP_GLOB) { 424116359Sasami return $self->pp_glob( 424245783Skato $op->first # entersub 424316359Sasami ->first # ex-list 424445783Skato ->first # pushmark 424545783Skato ->sibling, # glob 424616359Sasami $cx 424716359Sasami ); 424818846Sasami } elsif (!null($op->first->sibling) and 424918846Sasami $op->first->sibling->name eq "readline" and 425016359Sasami $op->first->sibling->flags & OPf_STACKED) { 425116359Sasami return $self->maybe_parens($self->deparse($op->first, 7) . " = " 425216359Sasami . $self->deparse($op->first->sibling, 7), 425320129Sasami $cx, 7); 425416359Sasami } elsif (!null($op->first->sibling) and 425516359Sasami $op->first->sibling->name =~ /^transr?\z/ and 425616359Sasami $op->first->sibling->flags & OPf_STACKED) { 425716359Sasami return $self->maybe_parens($self->deparse($op->first, 20) . " =~ " 425845783Skato . $self->deparse($op->first->sibling, 20), 425916359Sasami $cx, 20); 426018846Sasami } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) { 426116359Sasami return ($self->lex_in_scope("&do") ? "CORE::do" : "do") 426216359Sasami . " {\n\t". $self->deparse($op->first, $cx) ."\n\b};"; 426318846Sasami } elsif (!null($op->first->sibling) and 426418846Sasami $op->first->sibling->name eq "null" and 426518846Sasami class($op->first->sibling) eq "UNOP" and 426618846Sasami $op->first->sibling->first->flags & OPf_STACKED and 426718846Sasami $op->first->sibling->first->name eq "rcatline") { 426818846Sasami return $self->maybe_parens($self->deparse($op->first, 18) . " .= " 426945783Skato . $self->deparse($op->first->sibling, 18), 427018846Sasami $cx, 18); 427118846Sasami } else { 427218846Sasami return $self->deparse($op->first, $cx); 427318846Sasami } 427418846Sasami} 427518846Sasami 427616359Sasamisub padname { 427716359Sasami my $self = shift; 427816359Sasami my $targ = shift; 427916359Sasami return $self->padname_sv($targ)->PVX; 428016359Sasami} 428116359Sasami 428216359Sasamisub padany { 428316359Sasami my $self = shift; 428416359Sasami my $op = shift; 428516359Sasami return substr($self->padname($op->targ), 1); # skip $/@/% 428616359Sasami} 428745783Skato 428816359Sasamisub pp_padsv { 428945783Skato my $self = shift; 429016359Sasami my($op, $cx, $forbid_parens) = @_; 429116359Sasami my $targ = $op->targ; 429216359Sasami return $self->maybe_my($op, $cx, $self->padname($targ), 429316359Sasami $self->padname_sv($targ), 429445783Skato $forbid_parens); 429518846Sasami} 429618846Sasami 429718846Sasamisub pp_padav { pp_padsv(@_) } 429818846Sasami 429918846Sasami# prepend 'keys' where its been optimised away, with suitable handling 430016359Sasami# of CORE:: and parens 430116359Sasami 430216359Sasamisub add_keys_keyword { 430316359Sasami my ($self, $str, $cx) = @_; 430416359Sasami $str = $self->maybe_parens($str, $cx, 16); 430516359Sasami # 'keys %h' versus 'keys(%h)' 430616359Sasami $str = " $str" unless $str =~ /^\(/; 430716359Sasami return $self->keyword("keys") . $str; 430866250Skato} 430966250Skato 431051202Snyansub pp_padhv { 431116359Sasami my ($self, $op, $cx) = @_; 431216359Sasami my $str = pp_padsv(@_); 431316359Sasami # with OPpPADHV_ISKEYS the keys op is optimised away, except 431432089Skato # in scalar context the old op is kept (but not executed) so its targ 431532089Skato # can be used. 431645783Skato if ( ($op->private & OPpPADHV_ISKEYS) 431724655Skato && !(($op->flags & OPf_WANT) == OPf_WANT_SCALAR)) 431816359Sasami { 431924655Skato $str = $self->add_keys_keyword($str, $cx); 432024655Skato } 432124655Skato $str; 432224655Skato} 432324655Skato 432424655Skatosub gv_or_padgv { 432524655Skato my $self = shift; 432624655Skato my $op = shift; 432724655Skato if (class($op) eq "PADOP") { 432824655Skato return $self->padval($op->padix); 432924655Skato } else { # class($op) eq "SVOP" 433024655Skato return $op->gv; 433124655Skato } 433224655Skato} 433324655Skato 433445783Skatosub pp_gvsv { 433545783Skato my $self = shift; 433645783Skato my($op, $cx) = @_; 433751202Snyan my $gv = $self->gv_or_padgv($op); 433851202Snyan return $self->maybe_local($op, $cx, $self->stash_variable("\$", 433951202Snyan $self->gv_name($gv), $cx)); 434051202Snyan} 434151202Snyan 434245783Skatosub pp_gv { 434345783Skato my $self = shift; 434446766Skato my($op, $cx) = @_; 434545783Skato my $gv = $self->gv_or_padgv($op); 434646766Skato return $self->maybe_qualify("", $self->gv_name($gv)); 434746766Skato} 434845783Skato 434945783Skatosub pp_aelemfastlex_store { 435046766Skato my $self = shift; 435124655Skato my($op, $cx) = @_; 435226439Skato my $name = $self->padname($op->targ); 435346766Skato $name =~ s/^@/\$/; 435426439Skato my $i = $op->private; 435526439Skato $i -= 256 if $i > 127; 435626439Skato my $val = $self->deparse($op->first, 7); 435732089Skato return $self->maybe_parens("${name}[$i] = $val", $cx, 7); 435832089Skato} 435932089Skato 436032089Skatosub pp_aelemfast_lex { 436132089Skato my $self = shift; 436232089Skato my($op, $cx) = @_; 436332089Skato my $name = $self->padname($op->targ); 436432089Skato $name =~ s/^@/\$/; 436532089Skato my $i = $op->private; 436632089Skato $i -= 256 if $i > 127; 436746766Skato return $name . "[$i]"; 436846766Skato} 436946766Skato 437032089Skatosub pp_aelemfast { 437146766Skato my $self = shift; 437232089Skato my($op, $cx) = @_; 437346766Skato # optimised PADAV, pre 5.15 437432089Skato return $self->pp_aelemfast_lex(@_) if ($op->flags & OPf_SPECIAL); 437546766Skato 437646766Skato my $gv = $self->gv_or_padgv($op); 437724655Skato my($name,$quoted) = $self->stash_variable_name('@',$gv); 437846766Skato $name = $quoted ? "$name->" : '$' . $name; 437945783Skato my $i = $op->private; 438045783Skato $i -= 256 if $i > 127; 438124655Skato return $name . "[$i]"; 438224655Skato} 438346766Skato 438446766Skatosub rv2x { 438524655Skato my $self = shift; 438651202Snyan my($op, $cx, $type) = @_; 438746766Skato 438846766Skato if (class($op) eq 'NULL' || !$op->can("first")) { 438946766Skato carp("Unexpected op in pp_rv2x"); 439046871Skato return 'XXX'; 439146766Skato } 439246766Skato my $kid = $op->first; 439346766Skato if ($kid->name eq "gv") { 439446766Skato return $self->stash_variable($type, 439546766Skato $self->gv_name($self->gv_or_padgv($kid)), $cx); 439624655Skato } elsif (is_scalar $kid) { 439745783Skato my $str = $self->deparse($kid, 0); 439846766Skato if ($str =~ /^\$([^\w\d])\z/) { 439946871Skato # "$$+" isn't a legal way to write the scalar dereference 440046766Skato # of $+, since the lexer can't tell you aren't trying to 440146766Skato # do something like "$$ + 1" to get one more than your 440246766Skato # PID. Either "${$+}" or "$${+}" are workable 440346766Skato # disambiguations, but if the programmer did the former, 440446766Skato # they'd be in the "else" clause below rather than here. 440546871Skato # It's not clear if this should somehow be unified with 440646766Skato # the code in dq and re_dq that also adds lexer 440746766Skato # disambiguation braces. 440846766Skato $str = '$' . "{$1}"; #' 440946766Skato } 441046766Skato return $type . $str; 441146766Skato } else { 441246766Skato return $type . "{" . $self->deparse($kid, 0) . "}"; 441346766Skato } 441446766Skato} 441546766Skato 441646766Skatosub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) } 441746871Skatosub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) } 441816359Sasami 441916359Sasamisub pp_rv2hv { 442066250Skato my ($self, $op, $cx) = @_; 442166250Skato my $str = rv2x(@_, "%"); 442266250Skato if ($op->private & OPpRV2HV_ISKEYS) { 442366250Skato $str = $self->add_keys_keyword($str, $cx); 442466250Skato } 442566250Skato return maybe_local(@_, $str); 442666250Skato} 442766250Skato 442866250Skato# skip rv2av 442945783Skatosub pp_av2arylen { 443045783Skato my $self = shift; 443155900Skato my($op, $cx) = @_; 443245783Skato my $kid = $op->first; 443345783Skato if ($kid->name eq "padav") { 443445783Skato return $self->maybe_local($op, $cx, '$#' . $self->padany($kid)); 443545783Skato } else { 443645783Skato my $kkid; 443745783Skato if ( $kid->name eq "rv2av" 443845783Skato && ($kkid = $kid->first) 443945783Skato && $kkid->name !~ /^(scope|leave|gv)$/) 444045783Skato { 444145783Skato # handle (expr)->$#* postfix form 444245783Skato my $expr; 444345783Skato $expr = $self->deparse($kkid, 24); # 24 is '->' 444451202Snyan $expr = "$expr->\$#*"; 444551202Snyan # XXX maybe_local is probably wrong here: local($#-expression) 444645783Skato # doesn't "do" local (the is no INTRO flag set) 444745783Skato return $self->maybe_local($op, $cx, $expr); 444845783Skato } 444945783Skato else { 445045783Skato # handle $#{expr} form 445145783Skato # XXX see maybe_local comment above 445245783Skato return $self->maybe_local($op, $cx, $self->rv2x($kid, $cx, '$#')); 445345783Skato } 445445783Skato } 445545783Skato} 445645783Skato 445745783Skato# skip down to the old, ex-rv2cv 445845783Skatosub pp_rv2cv { 445945783Skato my ($self, $op, $cx) = @_; 446045783Skato if (!null($op->first) && $op->first->name eq 'null' && 446145783Skato $op->first->targ == OP_LIST) 446245783Skato { 446345783Skato return $self->rv2x($op->first->first->sibling, $cx, "&") 446445783Skato } 446545783Skato else { 446645783Skato return $self->rv2x($op, $cx, "") 446745783Skato } 446845783Skato} 446951202Snyan 447058888Skatosub list_const { 447145783Skato my $self = shift; 447245783Skato my($cx, @list) = @_; 447345783Skato my @a = map $self->const($_, 6), @list; 447445783Skato if (@a == 0) { 447545783Skato return "()"; 447645783Skato } elsif (@a == 1) { 447745783Skato return $a[0]; 447845783Skato } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) { 447945783Skato # collapse (-1,0,1,2) into (-1..2) 448045783Skato my ($s, $e) = @a[0,-1]; 448165810Skato my $i = $s; 448245783Skato return $self->maybe_parens("$s..$e", $cx, 9) 448345783Skato unless grep $i++ != $_, @a; 448445783Skato } 448545783Skato return $self->maybe_parens(join(", ", @a), $cx, 6); 448665810Skato} 448765810Skato 448865810Skatosub pp_rv2av { 448965810Skato my $self = shift; 449065810Skato my($op, $cx) = @_; 449165810Skato my $kid = $op->first; 449265810Skato if ($kid->name eq "const") { # constant list 449365810Skato my $av = $self->const_sv($kid); 449445783Skato return $self->list_const($cx, $av->ARRAY); 449545783Skato } else { 449645783Skato return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@")); 449745783Skato } 449845783Skato } 449945783Skato 450045783Skatosub is_subscriptable { 450145783Skato my $op = shift; 450245783Skato if ($op->name =~ /^([ahg]elem|multideref$)/) { 450345783Skato return 1; 450445783Skato } elsif ($op->name eq "entersub") { 450545783Skato my $kid = $op->first; 450645783Skato return 0 unless null $kid->sibling; 450745783Skato $kid = $kid->first; 450845783Skato $kid = $kid->sibling until null $kid->sibling; 450945783Skato return 0 if is_scope($kid); 451045783Skato $kid = $kid->first; 451145783Skato return 0 if $kid->name eq "gv" || $kid->name eq "padcv"; 451245783Skato return 0 if is_scalar($kid); 451345783Skato return is_subscriptable($kid); 451445783Skato } else { 451545783Skato return 0; 451658888Skato } 451745783Skato} 451845783Skato 451945783Skatosub elem_or_slice_array_name 452045783Skato{ 452151202Snyan my $self = shift; 452216359Sasami my ($array, $left, $padname, $allow_arrow) = @_; 452316359Sasami 452416359Sasami if ($array->name eq $padname) { 452516359Sasami return $self->padany($array); 452616359Sasami } elsif (is_scope($array)) { # ${expr}[0] 452716359Sasami return "{" . $self->deparse($array, 0) . "}"; 452816359Sasami } elsif ($array->name eq "gv") { 452916359Sasami ($array, my $quoted) = 453046766Skato $self->stash_variable_name( 453146766Skato $left eq '[' ? '@' : '%', $self->gv_or_padgv($array) 453246766Skato ); 453346766Skato if (!$allow_arrow && $quoted) { 453416359Sasami # This cannot happen. 453545783Skato die "Invalid variable name $array for slice"; 453616359Sasami } 453716359Sasami return $quoted ? "$array->" : $array; 453816359Sasami } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ... 453918846Sasami return $self->deparse($array, 24); 454045783Skato } else { 454116359Sasami return undef; 454216359Sasami } 454316359Sasami} 454416359Sasami 454516359Sasamisub elem_or_slice_single_index 454616359Sasami{ 454716359Sasami my $self = shift; 454816359Sasami my ($idx) = @_; 454916359Sasami 455016359Sasami $idx = $self->deparse($idx, 1); 455116359Sasami 455216359Sasami # Outer parens in an array index will confuse perl 455316359Sasami # if we're interpolating in a regular expression, i.e. 455416359Sasami # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/ 455546766Skato # 455646766Skato # If $self->{parens}, then an initial '(' will 455746766Skato # definitely be paired with a final ')'. If 455846766Skato # !$self->{parens}, the misleading parens won't 455916359Sasami # have been added in the first place. 456045783Skato # 456116359Sasami # [You might think that we could get "(...)...(...)" 456216359Sasami # where the initial and final parens do not match 456316359Sasami # each other. But we can't, because the above would 456445783Skato # only happen if there's an infix binop between the 456516359Sasami # two pairs of parens, and *that* means that the whole 456616359Sasami # expression would be parenthesized as well.] 456716359Sasami # 456816359Sasami $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'}; 456916359Sasami 457016359Sasami # Hash-element braces will autoquote a bareword inside themselves. 457116359Sasami # We need to make sure that C<$hash{warn()}> doesn't come out as 457216359Sasami # C<$hash{warn}>, which has a quite different meaning. Currently 457316359Sasami # B::Deparse will always quote strings, even if the string was a 457416359Sasami # bareword in the original (i.e. the OPpCONST_BARE flag is ignored 457516359Sasami # for constant strings.) So we can cheat slightly here - if we see 457646766Skato # a bareword, we know that it is supposed to be a function call. 457716359Sasami # 457846766Skato $idx =~ s/^([A-Za-z_]\w*)$/$1()/; 457946766Skato 458046766Skato return $idx; 458146766Skato} 458216359Sasami 458385149Snyansub elem { 458485149Snyan my $self = shift; 458546766Skato my ($op, $cx, $left, $right, $padname) = @_; 458646766Skato my($array, $idx) = ($op->first, $op->first->sibling); 458746766Skato 458846766Skato $idx = $self->elem_or_slice_single_index($idx); 458985149Snyan 459085149Snyan unless ($array->name eq $padname) { # Maybe this has been fixed 459116359Sasami $array = $array->first; # skip rv2av (or ex-rv2av in _53+) 459216359Sasami } 459316359Sasami if (my $array_name=$self->elem_or_slice_array_name 459445816Skato ($array, $left, $padname, 1)) { 459545783Skato return ($array_name =~ /->\z/ 459645783Skato ? $array_name 459745783Skato : $array_name eq '#' ? '${#}' : "\$" . $array_name) 459845783Skato . $left . $idx . $right; 459945783Skato } else { 460045783Skato # $x[20][3]{hi} or expr->[20] 460145783Skato my $arrow = is_subscriptable($array) ? "" : "->"; 460216359Sasami return $self->deparse($array, 24) . $arrow . $left . $idx . $right; 460345783Skato } 460445783Skato 460545783Skato} 460645783Skato 460745783Skato# a simplified version of elem_or_slice_array_name() 460845783Skato# for the use of pp_multideref 460945783Skato 461045783Skatosub multideref_var_name { 461145783Skato my $self = shift; 461245783Skato my ($gv, $is_hash) = @_; 461345783Skato 461445783Skato my ($name, $quoted) = 461545783Skato $self->stash_variable_name( $is_hash ? '%' : '@', $gv); 461645783Skato return $quoted ? "$name->" 461745783Skato : $name eq '#' 461845783Skato ? '${#}' # avoid ${#}[1] => $#[1] 461945783Skato : '$' . $name; 462045783Skato} 462145783Skato 462245783Skato 462345783Skato# deparse an OP_MULTICONCAT. If $in_dq is 1, we're within 462445783Skato# a double-quoted string, so for example. 462545783Skato# "abc\Qdef$x\Ebar" 462645783Skato# might get compiled as 462745783Skato# multiconcat("abc", metaquote(multiconcat("def", $x)), "bar") 462845816Skato# and the inner multiconcat should be deparsed as C<def$x> rather than 462945783Skato# the normal C<def . $x> 463052831Snyan# Ditto if $in_dq is 2, handle qr/...\Qdef$x\E.../. 463183539Snyan 463283539Snyansub do_multiconcat { 463383539Snyan my $self = shift; 463452831Snyan my($op, $cx, $in_dq) = @_; 463552831Snyan 463652831Snyan my $kid; 463758888Skato my @kids; 463858888Skato my $assign; 463978814Snyan my $append; 464058888Skato my $lhs = ""; 464145783Skato 464216359Sasami for ($kid = $op->first; !null $kid; $kid = $kid->sibling) { 464316359Sasami # skip the consts and/or padsv we've optimised away 464416359Sasami push @kids, $kid 464516359Sasami unless $kid->type == OP_NULL 464616359Sasami && ( $kid->targ == OP_PADSV 464716359Sasami || $kid->targ == OP_CONST 464816359Sasami || $kid->targ == OP_PUSHMARK); 464916359Sasami } 465016359Sasami 465116359Sasami $append = ($op->private & OPpMULTICONCAT_APPEND); 465216359Sasami 465316359Sasami if ($op->private & OPpTARGET_MY) { 465416359Sasami # '$lex = ...' or '$lex .= ....' or 'my $lex = ' 465516359Sasami $lhs = $self->padname($op->targ); 465616359Sasami $lhs = "my $lhs" if ($op->private & OPpLVAL_INTRO); 465716359Sasami $assign = 1; 465816359Sasami } 465916359Sasami elsif ($op->flags & OPf_STACKED) { 466016359Sasami # 'expr = ...' or 'expr .= ....' 466116359Sasami my $expr = $append ? shift(@kids) : pop(@kids); 466216359Sasami $lhs = $self->deparse($expr, 7); 466316359Sasami $assign = 1; 466416359Sasami } 466516359Sasami 466616359Sasami if ($assign) { 466716359Sasami $lhs .= $append ? ' .= ' : ' = '; 466816359Sasami } 466916359Sasami 467016359Sasami my ($nargs, $const_str, @const_lens) = $op->aux_list($self->{curcv}); 467116359Sasami 467216359Sasami my @consts; 467316359Sasami my $i = 0; 467416359Sasami for (@const_lens) { 467516359Sasami if ($_ == -1) { 467616359Sasami push @consts, undef; 467716359Sasami } 467816359Sasami else { 467916359Sasami push @consts, substr($const_str, $i, $_); 468016359Sasami my @args; 468116359Sasami $i += $_; 468216359Sasami } 468316359Sasami } 468416359Sasami 468516359Sasami my $rhs = ""; 468616359Sasami 468716359Sasami if ( $in_dq 468816359Sasami || (($op->private & OPpMULTICONCAT_STRINGIFY) && !$self->{'unquote'})) 468916359Sasami { 469016359Sasami # "foo=$foo bar=$bar " 469116359Sasami my $not_first; 469216359Sasami while (@consts) { 469316359Sasami if ($not_first) { 469416359Sasami my $s = $self->dq(shift(@kids), 18); 469516359Sasami # don't deparse "a${$}b" as "a$$b" 469616359Sasami $s = '${$}' if $s eq '$$'; 469716359Sasami $rhs = dq_disambiguate($rhs, $s); 469816359Sasami } 469916359Sasami $not_first = 1; 470016359Sasami my $c = shift @consts; 470116359Sasami if (defined $c) { 470216359Sasami if ($in_dq == 2) { 470316359Sasami # in pattern: don't convert newline to '\n' etc etc 470416359Sasami my $s = re_uninterp(escape_re(re_unback($c))); 470516359Sasami $rhs = re_dq_disambiguate($rhs, $s) 470616359Sasami } 470716359Sasami else { 470816359Sasami my $s = uninterp(escape_str(unback($c))); 470916359Sasami $rhs = dq_disambiguate($rhs, $s) 471016359Sasami } 471116359Sasami } 471216359Sasami } 471316359Sasami return $rhs if $in_dq; 471416359Sasami $rhs = single_delim("qq", '"', $rhs, $self); 471516359Sasami } 471616359Sasami elsif ($op->private & OPpMULTICONCAT_FAKE) { 471716359Sasami # sprintf("foo=%s bar=%s ", $foo, $bar) 471816359Sasami 471954174Snyan my @all; 472054174Snyan @consts = map { $_ //= ''; s/%/%%/g; $_ } @consts; 472154174Snyan my $fmt = join '%s', @consts; 472254174Snyan push @all, $self->quoted_const_str($fmt); 472354174Snyan 472454174Snyan # the following is a stripped down copy of sub listop {} 472554174Snyan my $parens = $assign || ($cx >= 5) || $self->{'parens'}; 472654174Snyan my $fullname = $self->keyword('sprintf'); 472716359Sasami push @all, map $self->deparse($_, 6), @kids; 472854174Snyan 472954174Snyan $rhs = $parens 473054174Snyan ? "$fullname(" . join(", ", @all) . ")" 473154174Snyan : "$fullname " . join(", ", @all); 473254174Snyan } 473354174Snyan else { 473454174Snyan # "foo=" . $foo . " bar=" . $bar 473554174Snyan my @all; 473654174Snyan my $not_first; 473754174Snyan while (@consts) { 473854174Snyan push @all, $self->deparse(shift(@kids), 18) if $not_first; 473954174Snyan $not_first = 1; 474054174Snyan my $c = shift @consts; 474154174Snyan if (defined $c) { 474254174Snyan push @all, $self->quoted_const_str($c); 474354174Snyan } 474454174Snyan } 474554174Snyan $rhs .= join ' . ', @all; 474616359Sasami } 474716359Sasami 474816359Sasami my $text = $lhs . $rhs; 474916359Sasami 475016359Sasami $text = "($text)" if ($cx >= (($assign) ? 7 : 18+1)) 475116359Sasami || $self->{'parens'}; 475216359Sasami 475316359Sasami return $text; 475416359Sasami} 475516359Sasami 475616359Sasami 475716359Sasamisub pp_multiconcat { 475816359Sasami my $self = shift; 475916359Sasami $self->do_multiconcat(@_, 0); 476016359Sasami} 476116359Sasami 476216359Sasami 476316359Sasamisub pp_multideref { 476416359Sasami my $self = shift; 476516359Sasami my($op, $cx) = @_; 476616359Sasami my $text = ""; 476716359Sasami 476816359Sasami if ($op->private & OPpMULTIDEREF_EXISTS) { 476916359Sasami $text = $self->keyword("exists"). " "; 477016359Sasami } 477116359Sasami elsif ($op->private & OPpMULTIDEREF_DELETE) { 477216359Sasami $text = $self->keyword("delete"). " "; 477316359Sasami } 477416359Sasami elsif ($op->private & OPpLVAL_INTRO) { 477516359Sasami $text = $self->keyword("local"). " "; 477643539Skato } 477743539Skato 477816359Sasami if ($op->first && ($op->first->flags & OPf_KIDS)) { 477916359Sasami # arbitrary initial expression, e.g. f(1,2,3)->[...] 478016359Sasami my $expr = $self->deparse($op->first, 24); 478116359Sasami # stop "exists (expr)->{...}" being interpreted as 478216359Sasami #"(exists (expr))->{...}" 478316359Sasami $expr = "+$expr" if $expr =~ /^\(/; 478416359Sasami $text .= $expr; 478516359Sasami } 478616359Sasami 478716359Sasami my @items = $op->aux_list($self->{curcv}); 478816359Sasami my $actions = shift @items; 478916359Sasami 479016359Sasami my $is_hash; 479116359Sasami my $derefs = 0; 479216359Sasami 479316359Sasami while (1) { 479416359Sasami if (($actions & MDEREF_ACTION_MASK) == MDEREF_reload) { 479516359Sasami $actions = shift @items; 479616359Sasami next; 479716359Sasami } 479816359Sasami 479916359Sasami $is_hash = ( 480016359Sasami ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_pop_rv2hv_helem 480116359Sasami || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvsv_vivify_rv2hv_helem 480216359Sasami || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padsv_vivify_rv2hv_helem 480316359Sasami || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_vivify_rv2hv_helem 480416359Sasami || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem 480516359Sasami || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem 480616359Sasami ); 480716359Sasami 480816359Sasami if ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_padav_aelem 480916359Sasami || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem) 481016359Sasami { 481116359Sasami $derefs = 1; 481216359Sasami $text .= '$' . substr($self->padname(shift @items), 1); 481316359Sasami } 481416359Sasami elsif ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_gvav_aelem 481516359Sasami || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem) 481616359Sasami { 481716359Sasami $derefs = 1; 481816359Sasami $text .= $self->multideref_var_name(shift @items, $is_hash); 481916359Sasami } 482016359Sasami else { 482116359Sasami if ( ($actions & MDEREF_ACTION_MASK) == 482216359Sasami MDEREF_AV_padsv_vivify_rv2av_aelem 482316359Sasami || ($actions & MDEREF_ACTION_MASK) == 482416359Sasami MDEREF_HV_padsv_vivify_rv2hv_helem) 482516359Sasami { 482616359Sasami $text .= $self->padname(shift @items); 482716359Sasami } 482816359Sasami elsif ( ($actions & MDEREF_ACTION_MASK) == 482916359Sasami MDEREF_AV_gvsv_vivify_rv2av_aelem 483016359Sasami || ($actions & MDEREF_ACTION_MASK) == 483116359Sasami MDEREF_HV_gvsv_vivify_rv2hv_helem) 483216359Sasami { 483316359Sasami $text .= $self->multideref_var_name(shift @items, $is_hash); 483416359Sasami } 483516359Sasami elsif ( ($actions & MDEREF_ACTION_MASK) == 483616359Sasami MDEREF_AV_pop_rv2av_aelem 483716359Sasami || ($actions & MDEREF_ACTION_MASK) == 483816359Sasami MDEREF_HV_pop_rv2hv_helem) 483916359Sasami { 484016359Sasami if ( ($op->flags & OPf_KIDS) 484116359Sasami && ( _op_is_or_was($op->first, OP_RV2AV) 484216359Sasami || _op_is_or_was($op->first, OP_RV2HV)) 484316359Sasami && ($op->first->flags & OPf_KIDS) 484416359Sasami && ( _op_is_or_was($op->first->first, OP_AELEM) 484516359Sasami || _op_is_or_was($op->first->first, OP_HELEM)) 484616359Sasami ) 484716359Sasami { 484816359Sasami $derefs++; 484916359Sasami } 485016359Sasami } 485116359Sasami 485216359Sasami $text .= '->' if !$derefs++; 485316359Sasami } 485416359Sasami 485516359Sasami 485616359Sasami if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_none) { 485754174Snyan last; 485854174Snyan } 485916359Sasami 486016359Sasami $text .= $is_hash ? '{' : '['; 486154174Snyan 486254174Snyan if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_const) { 486316359Sasami my $key = shift @items; 486416359Sasami if ($is_hash) { 486516359Sasami $text .= $self->const($key, $cx); 486616359Sasami } 486716359Sasami else { 486816359Sasami $text .= $key; 486916359Sasami } 487016359Sasami } 487116359Sasami elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_padsv) { 487254174Snyan $text .= $self->padname(shift @items); 487354174Snyan } 487416359Sasami elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_gvsv) { 487516359Sasami $text .= '$' . ($self->stash_variable_name('$', shift @items))[0]; 487616359Sasami } 487754174Snyan 487854174Snyan $text .= $is_hash ? '}' : ']'; 487916359Sasami 488016359Sasami if ($actions & MDEREF_FLAG_last) { 488116359Sasami last; 488216359Sasami } 488316359Sasami $actions >>= MDEREF_SHIFT; 488416359Sasami } 488516359Sasami 488616359Sasami return $text; 488716359Sasami} 488854174Snyan 488954174Snyan 489016359Sasamisub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) } 489116359Sasamisub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) } 489216359Sasami 489354174Snyansub pp_gelem { 489454174Snyan my $self = shift; 489516359Sasami my($op, $cx) = @_; 489616359Sasami my($glob, $part) = ($op->first, $op->last); 489716359Sasami $glob = $glob->first; # skip rv2gv 489816359Sasami $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug 489916359Sasami my $scope = is_scope($glob); 490016359Sasami $glob = $self->deparse($glob, 0); 490116359Sasami $part = $self->deparse($part, 1); 490216359Sasami $glob =~ s/::\z// unless $scope; 490354174Snyan return "*" . ($scope ? "{$glob}" : $glob) . "{$part}"; 490454174Snyan} 490516359Sasami 490616359Sasamisub slice { 490716359Sasami my $self = shift; 490816359Sasami my ($op, $cx, $left, $right, $regname, $padname) = @_; 490954174Snyan my $last; 491054174Snyan my(@elems, $kid, $array, $list); 491116359Sasami if (class($op) eq "LISTOP") { 491216359Sasami $last = $op->last; 491316359Sasami } else { # ex-hslice inside delete() 491416359Sasami for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {} 491516359Sasami $last = $kid; 491616359Sasami } 491716359Sasami $array = $last; 491816359Sasami $array = $array->first 491916359Sasami if $array->name eq $regname or $array->name eq "null"; 492016359Sasami $array = $self->elem_or_slice_array_name($array,$left,$padname,0); 492116359Sasami $kid = $op->first->sibling; # skip pushmark 492216359Sasami if ($kid->name eq "list") { 492316359Sasami $kid = $kid->first->sibling; # skip list, pushmark 492416359Sasami for (; !null $kid; $kid = $kid->sibling) { 492516359Sasami push @elems, $self->deparse($kid, 6); 492616359Sasami } 492716359Sasami $list = join(", ", @elems); 492816359Sasami } else { 492954174Snyan $list = $self->elem_or_slice_single_index($kid); 493054174Snyan } 493116359Sasami my $lead = ( _op_is_or_was($op, OP_KVHSLICE) 493216359Sasami || _op_is_or_was($op, OP_KVASLICE)) 493316359Sasami ? '%' : '@'; 493416359Sasami return $lead . $array . $left . $list . $right; 493516359Sasami} 493616359Sasami 493716359Sasamisub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) } 493816359Sasamisub pp_kvaslice { slice(@_, "[", "]", "rv2av", "padav") } 493916359Sasamisub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) } 494016359Sasamisub pp_kvhslice { slice(@_, "{", "}", "rv2hv", "padhv") } 494116359Sasami 494216359Sasamisub pp_lslice { 494354174Snyan my $self = shift; 494454174Snyan my($op, $cx) = @_; 494554174Snyan my $idx = $op->first; 494654174Snyan my $list = $op->last; 494716359Sasami my(@elems, $kid); 494816359Sasami $list = $self->deparse($list, 1); 494916359Sasami $idx = $self->deparse($idx, 1); 495016359Sasami return "($list)" . "[$idx]"; 495116359Sasami} 495216359Sasami 495316359Sasamisub want_scalar { 495416359Sasami my $op = shift; 495516359Sasami return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR; 495616359Sasami} 495716359Sasami 495816359Sasamisub want_list { 495916359Sasami my $op = shift; 496016359Sasami return ($op->flags & OPf_WANT) == OPf_WANT_LIST; 496116359Sasami} 496216359Sasami 496316359Sasamisub _method { 496416359Sasami my $self = shift; 496516359Sasami my($op, $cx) = @_; 496617256Sasami my $kid = $op->first->sibling; # skip pushmark 496716359Sasami my($meth, $obj, @exprs); 496816359Sasami if ($kid->name eq "list" and want_list $kid) { 496916359Sasami # When an indirect object isn't a bareword but the args are in 497016359Sasami # parens, the parens aren't part of the method syntax (the LLAFR 497116359Sasami # doesn't apply), but they make a list with OPf_PARENS set that 497216359Sasami # doesn't get flattened by the append_elem that adds the method, 497316359Sasami # making a (object, arg1, arg2, ...) list where the object 497416359Sasami # usually is. This can be distinguished from 497516359Sasami # '($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an 497616359Sasami # object) because in the later the list is in scalar context 497716359Sasami # as the left side of -> always is, while in the former 497816359Sasami # the list is in list context as method arguments always are. 497916359Sasami # (Good thing there aren't method prototypes!) 498016359Sasami $meth = $kid->sibling; 498116359Sasami $kid = $kid->first->sibling; # skip pushmark 498216359Sasami $obj = $kid; 498316359Sasami $kid = $kid->sibling; 498416359Sasami for (; not null $kid; $kid = $kid->sibling) { 498516359Sasami push @exprs, $kid; 498616359Sasami } 498716359Sasami } else { 498816359Sasami $obj = $kid; 498916359Sasami $kid = $kid->sibling; 499016359Sasami for (; !null ($kid->sibling) && $kid->name!~/^method(?:_named)?\z/; 499116359Sasami $kid = $kid->sibling) { 499216359Sasami push @exprs, $kid 499316359Sasami } 499416359Sasami $meth = $kid; 499516359Sasami } 499616359Sasami 499716359Sasami if ($meth->name eq "method_named") { 499816359Sasami $meth = $self->meth_sv($meth)->PV; 499916359Sasami } elsif ($meth->name eq "method_super") { 500016359Sasami $meth = "SUPER::".$self->meth_sv($meth)->PV; 500116359Sasami } elsif ($meth->name eq "method_redir") { 500216359Sasami $meth = $self->meth_rclass_sv($meth)->PV.'::'.$self->meth_sv($meth)->PV; 500316359Sasami } elsif ($meth->name eq "method_redir_super") { 500416359Sasami $meth = $self->meth_rclass_sv($meth)->PV.'::SUPER::'. 500516359Sasami $self->meth_sv($meth)->PV; 500616359Sasami } else { 500716359Sasami $meth = $meth->first; 500816359Sasami if ($meth->name eq "const") { 500916359Sasami # As of 5.005_58, this case is probably obsoleted by the 501016359Sasami # method_named case above 501116359Sasami $meth = $self->const_sv($meth)->PV; # needs to be bare 501216359Sasami } 501316359Sasami } 501416359Sasami 501516359Sasami return { method => $meth, variable_method => ref($meth), 501616359Sasami object => $obj, args => \@exprs }, 501716359Sasami $cx; 501816359Sasami} 501942262Skato 502016359Sasami# compat function only 502142262Skatosub method { 502242262Skato my $self = shift; 502342262Skato my $info = $self->_method(@_); 502442262Skato return $self->e_method( $self->_method(@_) ); 502542262Skato} 502642262Skato 502742262Skatosub e_method { 502842262Skato my ($self, $info, $cx) = @_; 502942262Skato my $obj = $self->deparse($info->{object}, 24); 503042262Skato 503142262Skato my $meth = $info->{method}; 503242262Skato $meth = $self->deparse($meth, 1) if $info->{variable_method}; 503342262Skato my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} ); 503442262Skato if ($info->{object}->name eq 'scope' && want_list $info->{object}) { 503542262Skato # method { $object } 503642262Skato # This must be deparsed this way to preserve list context 503742262Skato # of $object. 503842262Skato my $need_paren = $cx >= 6; 503942262Skato return '(' x $need_paren 504042262Skato . $meth . substr($obj,2) # chop off the "do" 504142262Skato . " $args" 504242262Skato . ')' x $need_paren; 504342262Skato } 504442262Skato my $kid = $obj . "->" . $meth; 504542262Skato if (length $args) { 504642262Skato return $kid . "(" . $args . ")"; # parens mandatory 504742262Skato } else { 504842262Skato return $kid; 504942262Skato } 505042262Skato} 505142262Skato 505242262Skato# returns "&" if the prototype doesn't match the args, 505342262Skato# or ("", $args_after_prototype_demunging) if it does. 505442262Skatosub check_proto { 505542262Skato my $self = shift; 505642262Skato return "&" if $self->{'noproto'}; 505742262Skato my ($proto, @args) = @_; 505842262Skato my $doneok = 0; 505942262Skato my @reals; 506042262Skato $proto =~ s/^\s+//; 506142262Skato while (length $proto) { 506242262Skato $proto =~ s/^(\\?[\$\@&%*]|\\\[[\$\@&%*]+\]|[_+;])\s*// 506342262Skato or return "&"; # malformed prototype 506442262Skato my $chr = $1; 506542262Skato if ($chr eq ";") { 506642262Skato $doneok = 1; 506742262Skato } elsif ($chr eq '@' or $chr eq '%') { 506842262Skato # An unbackslashed @ or % gobbles up the rest of the args 506942262Skato push @reals, map($self->deparse($_, 6), @args); 507016359Sasami @args = (); 507142262Skato $proto = ''; 507216359Sasami } elsif (!@args) { 507342262Skato last if $doneok; 507416359Sasami return "&"; # too few args and no ';' 507516359Sasami } else { 507616359Sasami my $arg = shift @args; 507716359Sasami if ($chr eq '$' || $chr eq '_') { 507842262Skato if (want_scalar $arg) { 507916359Sasami push @reals, $self->deparse($arg, 6); 508042262Skato } else { 508116359Sasami return "&"; 508242262Skato } 508360472Snyan } elsif ($chr eq "&") { 508442262Skato if ($arg->name =~ /^(?:s?refgen|undef)\z/) { 508542262Skato push @reals, $self->deparse($arg, 6); 508642262Skato } else { 508742262Skato return "&"; 508842262Skato } 508942262Skato } elsif ($chr eq "*") { 509042262Skato if ($arg->name =~ /^s?refgen\z/ 509142262Skato and $arg->first->first->name eq "rv2gv") 509242262Skato { 509342262Skato my $real = $arg->first->first; # skip refgen, null 509442262Skato if ($real->first->name eq "gv") { 509542262Skato push @reals, $self->deparse($real, 6); 509642262Skato } else { 509742262Skato push @reals, $self->deparse($real->first, 6); 509842262Skato } 509942262Skato } else { 510042262Skato return "&"; 510142262Skato } 510242262Skato } elsif ($chr eq "+") { 510342262Skato my $real; 510416359Sasami if ($arg->name =~ /^s?refgen\z/ and 510542262Skato !null($real = $arg->first) and 510642262Skato !null($real->first) and 510742262Skato $real->first->name =~ /^(?:rv2|pad)[ah]v\z/) 510842262Skato { 510942262Skato push @reals, $self->deparse($real, 6); 511042262Skato } elsif (want_scalar $arg) { 511142262Skato push @reals, $self->deparse($arg, 6); 511242262Skato } else { 511342262Skato return "&"; 511442262Skato } 511542262Skato } elsif (substr($chr, 0, 1) eq "\\") { 511642262Skato $chr =~ tr/\\[]//d; 511742262Skato my $real; 511842262Skato if ($arg->name =~ /^s?refgen\z/ and 511942262Skato !null($real = $arg->first) and 512042262Skato ($chr =~ /\$/ && is_scalar($real->first) 512142262Skato or ($chr =~ /@/ 512242262Skato && !null($real->first) 512342262Skato && $real->first->name =~ /^(?:rv2|pad)av\z/) 512442262Skato or ($chr =~ /%/ 512542262Skato && !null($real->first) 512642262Skato && $real->first->name =~ /^(?:rv2|pad)hv\z/) 512742262Skato #or ($chr =~ /&/ # This doesn't work 512816359Sasami # && $real->first->name eq "rv2cv") 512942262Skato or ($chr =~ /\*/ 513042262Skato && $real->first->name eq "rv2gv"))) 513142262Skato { 513242262Skato push @reals, $self->deparse($real, 6); 513342262Skato } else { 513442262Skato return "&"; 513516359Sasami } 513642262Skato } else { 513716359Sasami # should not happen 513816359Sasami return "&"; 513916359Sasami } 514045783Skato } 514116359Sasami } 514242262Skato return "&" if @args; # too many args 514316359Sasami return ("", join ", ", @reals); 514416359Sasami} 514516359Sasami 514616359Sasamisub retscalar { 514742262Skato my $name = $_[0]->name; 514860472Snyan # XXX There has to be a better way of doing this scalar-op check. 514916359Sasami # Currently PL_opargs is not exposed. 515045783Skato if ($name eq 'null') { 515142262Skato $name = substr B::ppname($_[0]->targ), 3 515242262Skato } 515342262Skato $name =~ /^(?:scalar|pushmark|wantarray|const|gvsv|gv|padsv|rv2gv 515442262Skato |rv2sv|av2arylen|anoncode|prototype|srefgen|ref|bless 515542262Skato |regcmaybe|regcreset|regcomp|qr|subst|substcont|trans 515642262Skato |transr|sassign|chop|schop|chomp|schomp|defined|undef 515742262Skato |study|pos|preinc|i_preinc|predec|i_predec|postinc 515842262Skato |i_postinc|postdec|i_postdec|pow|multiply|i_multiply 515942262Skato |divide|i_divide|modulo|i_modulo|add|i_add|subtract 516042262Skato |i_subtract|concat|multiconcat|stringify|left_shift|right_shift|lt 516142262Skato |i_lt|gt|i_gt|le|i_le|ge|i_ge|eq|i_eq|ne|i_ne|ncmp|i_ncmp 516242262Skato |slt|sgt|sle|sge|seq|sne|scmp|[sn]?bit_(?:and|x?or)|negate 516342262Skato |i_negate|not|[sn]?complement|smartmatch|atan2|sin|cos 516442262Skato |rand|srand|exp|log|sqrt|int|hex|oct|abs|length|substr 516542262Skato |vec|index|rindex|sprintf|formline|ord|chr|crypt|ucfirst 516642262Skato |lcfirst|uc|lc|quotemeta|aelemfast|aelem|exists|helem 516742262Skato |pack|join|anonlist|anonhash|push|pop|shift|unshift|xor 516854174Snyan |andassign|orassign|dorassign|warn|die|reset|nextstate 516954174Snyan |dbstate|unstack|last|next|redo|dump|goto|exit|open|close 517042262Skato |pipe_op|fileno|umask|binmode|tie|untie|tied|dbmopen 517142262Skato |dbmclose|select|getc|read|enterwrite|prtf|print|say 517242262Skato |sysopen|sysseek|sysread|syswrite|eof|tell|seek|truncate 517342262Skato |fcntl|ioctl|flock|send|recv|socket|sockpair|bind|connect 517445783Skato |listen|accept|shutdown|gsockopt|ssockopt|getsockname 517542262Skato |getpeername|ftrread|ftrwrite|ftrexec|fteread|ftewrite 517642262Skato |fteexec|ftis|ftsize|ftmtime|ftatime|ftctime|ftrowned 517742262Skato |fteowned|ftzero|ftsock|ftchr|ftblk|ftfile|ftdir|ftpipe 517842262Skato |ftsuid|ftsgid|ftsvtx|ftlink|fttty|fttext|ftbinary|chdir 517942262Skato |chown|chroot|unlink|chmod|utime|rename|link|symlink 518042262Skato |readlink|mkdir|rmdir|open_dir|telldir|seekdir|rewinddir 518142262Skato |closedir|fork|wait|waitpid|system|exec|kill|getppid 518251056Skato |getpgrp|setpgrp|getpriority|setpriority|time|alarm|sleep 518351056Skato |shmget|shmctl|shmread|shmwrite|msgget|msgctl|msgsnd 518416359Sasami |msgrcv|semop|semget|semctl|hintseval|shostent|snetent 518542262Skato |sprotoent|sservent|ehostent|enetent|eprotoent|eservent 518642262Skato |spwent|epwent|sgrent|egrent|getlogin|syscall|lock|runcv 518745783Skato |fc|padsv_store)\z/x 518842262Skato} 518942262Skato 519042262Skatosub pp_entersub { 519142262Skato my $self = shift; 519216359Sasami my($op, $cx) = @_; 519342262Skato return $self->e_method($self->_method($op, $cx)) 519416359Sasami unless null $op->first->sibling; 519516359Sasami my $prefix = ""; 519616359Sasami my $amper = ""; 519760472Snyan my($kid, @exprs); 519854174Snyan if ($op->private & OPpENTERSUB_AMPER) { 519916359Sasami $amper = "&"; 520054174Snyan } 520160472Snyan $kid = $op->first; 520216359Sasami $kid = $kid->first->sibling; # skip ex-list, pushmark 520360472Snyan for (; not null $kid->sibling; $kid = $kid->sibling) { 520460472Snyan push @exprs, $kid; 520560472Snyan } 520660472Snyan my $simple = 0; 520760472Snyan my $proto = undef; 520860472Snyan my $lexical; 520916359Sasami if (is_scope($kid)) { 521054174Snyan $amper = "&"; 521154174Snyan $kid = "{" . $self->deparse($kid, 0) . "}"; 521254174Snyan } elsif ($kid->first->name eq "gv") { 521354174Snyan my $gv = $self->gv_or_padgv($kid->first); 521454174Snyan my $cv; 521554174Snyan if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL" 521654174Snyan || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') { 521754174Snyan $proto = $cv->PV if $cv->FLAGS & SVf_POK; 521854174Snyan } 521954174Snyan $simple = 1; # only calls of named functions can be prototyped 522054174Snyan $kid = $self->maybe_qualify("!", $self->gv_name($gv)); 522154174Snyan my $fq; 522254174Snyan # Fully qualify any sub name that conflicts with a lexical. 522354174Snyan if ($self->lex_in_scope("&$kid") 522454174Snyan || $self->lex_in_scope("&$kid", 1)) 522554174Snyan { 522654174Snyan $fq++; 522754174Snyan } elsif (!$amper) { 522854174Snyan if ($kid eq 'main::') { 522954174Snyan $kid = '::'; 523054174Snyan } 523154174Snyan else { 523254174Snyan if ($kid !~ /::/ && $kid ne 'x') { 523354174Snyan # Fully qualify any sub name that is also a keyword. While 523454174Snyan # we could check the import flag, we cannot guarantee that 523554174Snyan # the code deparsed so far would set that flag, so we qual- 523654174Snyan # ify the names regardless of importation. 523754174Snyan if (exists $feature_keywords{$kid}) { 523854174Snyan $fq++ if $self->feature_enabled($kid); 523954174Snyan } elsif (do { local $@; local $SIG{__DIE__}; 524054174Snyan eval { () = prototype "CORE::$kid"; 1 } }) { 524154174Snyan $fq++ 524254174Snyan } 524354174Snyan } 524454174Snyan if ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) { 524554174Snyan $kid = single_delim("q", "'", $kid, $self) . '->'; 524654174Snyan } 524716359Sasami } 5248 } 5249 $fq and substr $kid, 0, 0, = $self->{'curstash'}.'::'; 5250 } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') { 5251 $amper = "&"; 5252 $kid = $self->deparse($kid, 24); 5253 } else { 5254 $prefix = ""; 5255 my $grandkid = $kid->first; 5256 my $arrow = ($lexical = $grandkid->name eq "padcv") 5257 || is_subscriptable($grandkid) 5258 ? "" 5259 : "->"; 5260 $kid = $self->deparse($kid, 24) . $arrow; 5261 if ($lexical) { 5262 my $padlist = $self->{'curcv'}->PADLIST; 5263 my $padoff = $grandkid->targ; 5264 my $padname = $padlist->ARRAYelt(0)->ARRAYelt($padoff); 5265 my $protocv = $padname->FLAGS & SVpad_STATE 5266 ? $padlist->ARRAYelt(1)->ARRAYelt($padoff) 5267 : $padname->PROTOCV; 5268 if ($protocv->FLAGS & SVf_POK) { 5269 $proto = $protocv->PV 5270 } 5271 $simple = 1; 5272 } 5273 } 5274 5275 # Doesn't matter how many prototypes there are, if 5276 # they haven't happened yet! 5277 my $declared = $lexical || exists $self->{'subs_declared'}{$kid}; 5278 if (not $declared and $self->{'in_coderef2text'}) { 5279 no strict 'refs'; 5280 no warnings 'uninitialized'; 5281 $declared = 5282 ( 5283 defined &{ ${$self->{'curstash'}."::"}{$kid} } 5284 && !exists 5285 $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid} 5286 && defined prototype $self->{'curstash'}."::".$kid 5287 ); 5288 } 5289 if (!$declared && defined($proto)) { 5290 # Avoid "too early to check prototype" warning 5291 ($amper, $proto) = ('&'); 5292 } 5293 5294 my $args; 5295 my $listargs = 1; 5296 if ($declared and defined $proto and not $amper) { 5297 ($amper, $args) = $self->check_proto($proto, @exprs); 5298 $listargs = $amper; 5299 } 5300 if ($listargs) { 5301 $args = join(", ", map( 5302 ($_->flags & OPf_WANT) == OPf_WANT_SCALAR 5303 && !retscalar($_) 5304 ? $self->maybe_parens_unop('scalar', $_, 6) 5305 : $self->deparse($_, 6), 5306 @exprs 5307 )); 5308 } 5309 if ($prefix or $amper) { 5310 if ($kid eq '&') { $kid = "{$kid}" } # &{&} cannot be written as && 5311 if ($op->flags & OPf_STACKED) { 5312 return $prefix . $amper . $kid . "(" . $args . ")"; 5313 } else { 5314 return $prefix . $amper. $kid; 5315 } 5316 } else { 5317 # It's a syntax error to call CORE::GLOBAL::foo with a prefix, 5318 # so it must have been translated from a keyword call. Translate 5319 # it back. 5320 $kid =~ s/^CORE::GLOBAL:://; 5321 5322 if (!$declared) { 5323 return "$kid(" . $args . ")"; 5324 } 5325 5326 my $dproto = defined($proto) ? $proto : "undefined"; 5327 if ($dproto =~ /^\s*\z/) { 5328 return $kid; 5329 } 5330 5331 my $scalar_proto = $dproto =~ /^ \s* (?: ;\s* )* (?: [\$*_+] |\\ \s* (?: [\$\@%&*] | \[ [^\]]+ \] ) ) \s* \z/x; 5332 if ($scalar_proto and !@exprs || is_scalar($exprs[0])) { 5333 # is_scalar is an excessively conservative test here: 5334 # really, we should be comparing to the precedence of the 5335 # top operator of $exprs[0] (ala unop()), but that would 5336 # take some major code restructuring to do right. 5337 return $self->maybe_parens_func($kid, $args, $cx, 16); 5338 } elsif (not $scalar_proto and defined($proto) || $simple) { 5339 return $self->maybe_parens_func($kid, $args, $cx, 5); 5340 } else { 5341 return "$kid(" . $args . ")"; 5342 } 5343 } 5344} 5345 5346sub pp_enterwrite { unop(@_, "write") } 5347 5348# escape things that cause interpolation in double quotes, 5349# but not character escapes 5350sub uninterp { 5351 my($str) = @_; 5352 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g; 5353 return $str; 5354} 5355 5356{ 5357my $bal; 5358BEGIN { 5359 use re "eval"; 5360 # Matches any string which is balanced with respect to {braces} 5361 $bal = qr( 5362 (?: 5363 [^\\{}] 5364 | \\\\ 5365 | \\[{}] 5366 | \{(??{$bal})\} 5367 )* 5368 )x; 5369} 5370 5371# the same, but treat $|, $), $( and $ at the end of the string differently 5372# and leave comments unmangled for the sake of /x and (?x). 5373sub re_uninterp { 5374 my($str) = @_; 5375 5376 $str =~ s/ 5377 ( ^|\G # $1 5378 | [^\\] 5379 ) 5380 5381 ( # $2 5382 (?:\\\\)* 5383 ) 5384 5385 ( # $3 5386 ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks) 5387 | \#[^\n]* # (skip over comments) 5388 ) 5389 | [\$\@] 5390 (?!\||\)|\(|$|\s) 5391 | \\[uUlLQE] 5392 ) 5393 5394 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg; 5395 5396 return $str; 5397} 5398} 5399 5400# character escapes, but not delimiters that might need to be escaped 5401sub escape_str { # ASCII, UTF8 5402 my($str) = @_; 5403 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; 5404 $str =~ s/\a/\\a/g; 5405# $str =~ s/\cH/\\b/g; # \b means something different in a regex; and \cH 5406 # isn't a backspace in EBCDIC 5407 $str =~ s/\t/\\t/g; 5408 $str =~ s/\n/\\n/g; 5409 $str =~ s/\e/\\e/g; 5410 $str =~ s/\f/\\f/g; 5411 $str =~ s/\r/\\r/g; 5412 $str =~ s/([\cA-\cZ])/'\\c' . $unctrl{$1}/ge; 5413 $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/age; 5414 return $str; 5415} 5416 5417# For regexes. Leave whitespace unmangled in case of /x or (?x). 5418sub escape_re { 5419 my($str) = @_; 5420 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; 5421 $str =~ s/([[:^print:]])/ 5422 ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/age; 5423 $str =~ s/\n/\n\f/g; 5424 return $str; 5425} 5426 5427# Don't do this for regexen 5428sub unback { 5429 my($str) = @_; 5430 $str =~ s/\\/\\\\/g; 5431 return $str; 5432} 5433 5434# Remove backslashes which precede literal control characters, 5435# to avoid creating ambiguity when we escape the latter. 5436# 5437# Don't remove a backslash from escaped whitespace: where the T represents 5438# a literal tab character, /T/x is not equivalent to /\T/x 5439 5440sub re_unback { 5441 my($str) = @_; 5442 5443 # the insane complexity here is due to the behaviour of "\c\" 5444 $str =~ s/ 5445 # these two lines ensure that the backslash we're about to 5446 # remove isn't preceded by something which makes it part 5447 # of a \c 5448 5449 (^ | [^\\] | \\c\\) # $1 5450 (?<!\\c) 5451 5452 # the backslash to remove 5453 \\ 5454 5455 # keep pairs of backslashes 5456 (\\\\)* # $2 5457 5458 # only remove if the thing following is a control char 5459 (?=[[:^print:]]) 5460 # and not whitespace 5461 (?=\S) 5462 /$1$2/xg; 5463 return $str; 5464} 5465 5466sub balanced_delim { 5467 my($str) = @_; 5468 my @str = split //, $str; 5469 my($ar, $open, $close, $fail, $c, $cnt, $last_bs); 5470 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) { 5471 ($open, $close) = @$ar; 5472 $fail = 0; $cnt = 0; $last_bs = 0; 5473 for $c (@str) { 5474 if ($c eq $open) { 5475 $fail = 1 if $last_bs; 5476 $cnt++; 5477 } elsif ($c eq $close) { 5478 $fail = 1 if $last_bs; 5479 $cnt--; 5480 if ($cnt < 0) { 5481 # qq()() isn't ")(" 5482 $fail = 1; 5483 last; 5484 } 5485 } 5486 $last_bs = $c eq '\\'; 5487 } 5488 $fail = 1 if $cnt != 0; 5489 return ($open, "$open$str$close") if not $fail; 5490 } 5491 return ("", $str); 5492} 5493 5494sub single_delim { 5495 my($q, $default, $str, $self) = @_; 5496 return "$default$str$default" if $default and index($str, $default) == -1; 5497 my $coreq = $self->keyword($q); # maybe CORE::q 5498 if ($q ne 'qr') { 5499 (my $succeed, $str) = balanced_delim($str); 5500 return "$coreq$str" if $succeed; 5501 } 5502 for my $delim ('/', '"', '#') { 5503 return "$coreq$delim" . $str . $delim if index($str, $delim) == -1; 5504 } 5505 if ($default) { 5506 $str =~ s/$default/\\$default/g; 5507 return "$default$str$default"; 5508 } else { 5509 $str =~ s[/][\\/]g; 5510 return "$coreq/$str/"; 5511 } 5512} 5513 5514my $max_prec; 5515BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); } 5516 5517# Split a floating point number into an integer mantissa and a binary 5518# exponent. Assumes you've already made sure the number isn't zero or 5519# some weird infinity or NaN. 5520sub split_float { 5521 my($f) = @_; 5522 my $exponent = 0; 5523 if ($f == int($f)) { 5524 while ($f % 2 == 0) { 5525 $f /= 2; 5526 $exponent++; 5527 } 5528 } else { 5529 while ($f != int($f)) { 5530 $f *= 2; 5531 $exponent--; 5532 } 5533 } 5534 my $mantissa = sprintf("%.0f", $f); 5535 return ($mantissa, $exponent); 5536} 5537 5538 5539# suitably single- or double-quote a literal constant string 5540 5541sub quoted_const_str { 5542 my ($self, $str) =@_; 5543 if ($str =~ /[[:^print:]]/a) { 5544 return single_delim("qq", '"', 5545 uninterp(escape_str unback $str), $self); 5546 } else { 5547 return single_delim("q", "'", unback($str), $self); 5548 } 5549} 5550 5551 5552sub const { 5553 my $self = shift; 5554 my($sv, $cx) = @_; 5555 if ($self->{'use_dumper'}) { 5556 return $self->const_dumper($sv, $cx); 5557 } 5558 if (class($sv) eq "SPECIAL") { 5559 # PL_sv_undef etc 5560 # return yes/no as boolean expressions rather than integers to 5561 # preserve their boolean-ness 5562 return 5563 $$sv == 1 ? 'undef' : # PL_sv_undef 5564 $$sv == 2 ? $self->maybe_parens("!0", $cx, 21) : # PL_sv_yes 5565 $$sv == 3 ? $self->maybe_parens("!1", $cx, 21) : # PL_sv_no 5566 $$sv == 7 ? '0' : # PL_sv_zero 5567 '"???"'; 5568 } 5569 if (class($sv) eq "NULL") { 5570 return 'undef'; 5571 } 5572 # convert a version object into the "v1.2.3" string in its V magic 5573 if ($sv->FLAGS & SVs_RMG) { 5574 for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) { 5575 return $mg->PTR if $mg->TYPE eq 'V'; 5576 } 5577 } 5578 5579 if ($sv->FLAGS & SVf_IOK) { 5580 my $str = $sv->int_value; 5581 $str = $self->maybe_parens($str, $cx, 21) if $str < 0; 5582 return $str; 5583 } elsif ($sv->FLAGS & SVf_NOK) { 5584 my $nv = $sv->NV; 5585 if ($nv == 0) { 5586 if (pack("F", $nv) eq pack("F", 0)) { 5587 # positive zero 5588 return "0.0"; 5589 } else { 5590 # negative zero 5591 return $self->maybe_parens("-0.0", $cx, 21); 5592 } 5593 } elsif (1/$nv == 0) { 5594 if ($nv > 0) { 5595 # positive infinity 5596 return $self->maybe_parens("9**9**9", $cx, 22); 5597 } else { 5598 # negative infinity 5599 return $self->maybe_parens("-9**9**9", $cx, 21); 5600 } 5601 } elsif ($nv != $nv) { 5602 # NaN 5603 if (pack("F", $nv) eq pack("F", sin(9**9**9))) { 5604 # the normal kind 5605 return "sin(9**9**9)"; 5606 } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) { 5607 # the inverted kind 5608 return $self->maybe_parens("-sin(9**9**9)", $cx, 21); 5609 } else { 5610 # some other kind 5611 my $hex = unpack("h*", pack("F", $nv)); 5612 return qq'unpack("F", pack("h*", "$hex"))'; 5613 } 5614 } 5615 # first, try the default stringification 5616 my $str = "$nv"; 5617 if ($str != $nv) { 5618 # failing that, try using more precision 5619 $str = sprintf("%.${max_prec}g", $nv); 5620# if (pack("F", $str) ne pack("F", $nv)) { 5621 if ($str != $nv) { 5622 # not representable in decimal with whatever sprintf() 5623 # and atof() Perl is using here. 5624 my($mant, $exp) = split_float($nv); 5625 return $self->maybe_parens("$mant * 2**$exp", $cx, 19); 5626 } 5627 } 5628 5629 # preserve NV-ness: output as NNN.0 rather than NNN 5630 $str .= ".0" if $str =~ /^-?[0-9]+$/; 5631 5632 $str = $self->maybe_parens($str, $cx, 21) if $nv < 0; 5633 return $str; 5634 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) { 5635 my $ref = $sv->RV; 5636 my $class = class($ref); 5637 if ($class eq "AV") { 5638 return "[" . $self->list_const(2, $ref->ARRAY) . "]"; 5639 } elsif ($class eq "HV") { 5640 my %hash = $ref->ARRAY; 5641 my @elts; 5642 for my $k (sort keys %hash) { 5643 push @elts, "$k => " . $self->const($hash{$k}, 6); 5644 } 5645 return "{" . join(", ", @elts) . "}"; 5646 } elsif ($class eq "CV") { 5647 no overloading; 5648 if ($self->{curcv} && 5649 $self->{curcv}->object_2svref == $ref->object_2svref) { 5650 return $self->keyword("__SUB__"); 5651 } 5652 return "sub " . $self->deparse_sub($ref); 5653 } 5654 if ($class ne 'SPECIAL' and $ref->FLAGS & SVs_SMG) { 5655 for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) { 5656 if ($mg->TYPE eq 'r') { 5657 my $re = re_uninterp(escape_re(re_unback($mg->precomp))); 5658 return single_delim("qr", "", $re, $self); 5659 } 5660 } 5661 } 5662 5663 my $const = $self->const($ref, 20); 5664 if ($self->{in_subst_repl} && $const =~ /^[0-9]/) { 5665 $const = "($const)"; 5666 } 5667 return $self->maybe_parens("\\$const", $cx, 20); 5668 } elsif ($sv->FLAGS & SVf_POK) { 5669 my $str = $sv->PV; 5670 return $self->quoted_const_str($str); 5671 } else { 5672 return "undef"; 5673 } 5674} 5675 5676sub const_dumper { 5677 my $self = shift; 5678 my($sv, $cx) = @_; 5679 my $ref = $sv->object_2svref(); 5680 my $dumper = Data::Dumper->new([$$ref], ['$v']); 5681 $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1); 5682 my $str = $dumper->Dump(); 5683 if ($str =~ /^\$v/) { 5684 return '${my ' . $str . ' \$v}'; 5685 } else { 5686 return $str; 5687 } 5688} 5689 5690sub const_sv { 5691 my $self = shift; 5692 my $op = shift; 5693 my $sv = $op->sv; 5694 # the constant could be in the pad (under useithreads) 5695 $sv = $self->padval($op->targ) unless $$sv; 5696 return $sv; 5697} 5698 5699sub meth_sv { 5700 my $self = shift; 5701 my $op = shift; 5702 my $sv = $op->meth_sv; 5703 # the constant could be in the pad (under useithreads) 5704 $sv = $self->padval($op->targ) unless $$sv; 5705 return $sv; 5706} 5707 5708sub meth_rclass_sv { 5709 my $self = shift; 5710 my $op = shift; 5711 my $sv = $op->rclass; 5712 # the constant could be in the pad (under useithreads) 5713 $sv = $self->padval($sv) unless ref $sv; 5714 return $sv; 5715} 5716 5717sub pp_const { 5718 my $self = shift; 5719 my($op, $cx) = @_; 5720# if ($op->private & OPpCONST_BARE) { # trouble with '=>' autoquoting 5721# return $self->const_sv($op)->PV; 5722# } 5723 my $sv = $self->const_sv($op); 5724 return $self->const($sv, $cx); 5725} 5726 5727 5728# Join two components of a double-quoted string, disambiguating 5729# "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar" 5730 5731sub dq_disambiguate { 5732 my ($first, $last) = @_; 5733 ($last =~ /^[A-Z\\\^\[\]_?]/ && 5734 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc 5735 || ($last =~ /^[:'{\[\w_]/ && #' 5736 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/); 5737 return $first . $last; 5738} 5739 5740 5741# Deparse a double-quoted optree. For example, "$a[0]\Q$b\Efo\"o" gets 5742# compiled to concat(concat($[0],quotemeta($b)),const("fo\"o")), and this 5743# sub deparses it back to $a[0]\Q$b\Efo"o 5744# (It does not add delimiters) 5745 5746sub dq { 5747 my $self = shift; 5748 my $op = shift; 5749 my $type = $op->name; 5750 if ($type eq "const") { 5751 return uninterp(escape_str(unback($self->const_sv($op)->as_string))); 5752 } elsif ($type eq "concat") { 5753 return dq_disambiguate($self->dq($op->first), $self->dq($op->last)); 5754 } elsif ($type eq "multiconcat") { 5755 return $self->do_multiconcat($op, 26, 1); 5756 } elsif ($type eq "uc") { 5757 return '\U' . $self->dq($op->first->sibling) . '\E'; 5758 } elsif ($type eq "lc") { 5759 return '\L' . $self->dq($op->first->sibling) . '\E'; 5760 } elsif ($type eq "ucfirst") { 5761 return '\u' . $self->dq($op->first->sibling); 5762 } elsif ($type eq "lcfirst") { 5763 return '\l' . $self->dq($op->first->sibling); 5764 } elsif ($type eq "quotemeta") { 5765 return '\Q' . $self->dq($op->first->sibling) . '\E'; 5766 } elsif ($type eq "fc") { 5767 return '\F' . $self->dq($op->first->sibling) . '\E'; 5768 } elsif ($type eq "join") { 5769 return $self->deparse($op->last, 26); # was join($", @ary) 5770 } else { 5771 return $self->deparse($op, 26); 5772 } 5773} 5774 5775sub pp_backtick { 5776 my $self = shift; 5777 my($op, $cx) = @_; 5778 # skip pushmark if it exists (readpipe() vs ``) 5779 my $child = $op->first->sibling->isa('B::NULL') 5780 ? $op->first : $op->first->sibling; 5781 if ($self->pure_string($child)) { 5782 return single_delim("qx", '`', $self->dq($child, 1), $self); 5783 } 5784 unop($self, @_, "readpipe"); 5785} 5786 5787sub dquote { 5788 my $self = shift; 5789 my($op, $cx) = @_; 5790 my $kid = $op->first->sibling; # skip ex-stringify, pushmark 5791 return $self->deparse($kid, $cx) if $self->{'unquote'}; 5792 $self->maybe_targmy($kid, $cx, 5793 sub {single_delim("qq", '"', $self->dq($_[1]), 5794 $self)}); 5795} 5796 5797# OP_STRINGIFY is a listop, but it only ever has one arg 5798sub pp_stringify { 5799 my ($self, $op, $cx) = @_; 5800 my $kid = $op->first->sibling; 5801 while ($kid->name eq 'null' && !null($kid->first)) { 5802 $kid = $kid->first; 5803 } 5804 if ($kid->name =~ /^(?:const|padsv|rv2sv|av2arylen|gvsv|multideref 5805 |aelemfast(?:_lex)?|[ah]elem|join|concat)\z/x) { 5806 maybe_targmy(@_, \&dquote); 5807 } 5808 else { 5809 # Actually an optimised join. 5810 my $result = listop(@_,"join"); 5811 $result =~ s/join([( ])/join$1$self->{'ex_const'}, /; 5812 $result; 5813 } 5814} 5815 5816# tr/// and s/// (and tr[][], tr[]//, tr###, etc) 5817# note that tr(from)/to/ is OK, but not tr/from/(to) 5818sub double_delim { 5819 my($from, $to) = @_; 5820 my($succeed, $delim); 5821 if ($from !~ m[/] and $to !~ m[/]) { 5822 return "/$from/$to/"; 5823 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) { 5824 if (($succeed, $to) = balanced_delim($to) and $succeed) { 5825 return "$from$to"; 5826 } else { 5827 for $delim ('/', '"', '#') { # note no "'" -- s''' is special 5828 return "$from$delim$to$delim" if index($to, $delim) == -1; 5829 } 5830 $to =~ s[/][\\/]g; 5831 return "$from/$to/"; 5832 } 5833 } else { 5834 for $delim ('/', '"', '#') { # note no ' 5835 return "$delim$from$delim$to$delim" 5836 if index($to . $from, $delim) == -1; 5837 } 5838 $from =~ s[/][\\/]g; 5839 $to =~ s[/][\\/]g; 5840 return "/$from/$to/"; 5841 } 5842} 5843 5844# Escape a characrter. 5845# Only used by tr///, so backslashes hyphens 5846 5847sub pchr { 5848 my($n) = @_; 5849 return sprintf("\\x{%X}", $n) if $n > 255; 5850 return '\\\\' if $n == ord '\\'; 5851 return "\\-" if $n == ord "-"; 5852 # I'm presuming a regex is not ok here, otherwise we could have used 5853 # /[[:print:]]/a to get here 5854 return chr($n) if ( utf8::native_to_unicode($n) 5855 >= utf8::native_to_unicode(ord(' ')) 5856 and utf8::native_to_unicode($n) 5857 <= utf8::native_to_unicode(ord('~'))); 5858 5859 my $mnemonic_pos = index("\a\b\e\f\n\r\t", chr($n)); 5860 return "\\" . substr("abefnrt", $mnemonic_pos, 1) if $mnemonic_pos >= 0; 5861 5862 return '\\c' . $unctrl{chr $n} if $n >= ord("\cA") and $n <= ord("\cZ"); 5863# return '\x' . sprintf("%02x", $n); 5864 return '\\' . sprintf("%03o", $n); 5865} 5866 5867# Convert a list of characters into a string suitable for tr/// search or 5868# replacement, with suitable escaping and collapsing of ranges 5869 5870sub collapse { 5871 my(@chars) = @_; 5872 my($str, $c, $tr) = (""); 5873 for ($c = 0; $c < @chars; $c++) { 5874 $tr = $chars[$c]; 5875 $str .= pchr($tr); 5876 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and 5877 $chars[$c + 2] == $tr + 2) 5878 { 5879 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++) 5880 {} 5881 $str .= "-"; 5882 $str .= pchr($chars[$c]); 5883 } 5884 } 5885 return $str; 5886} 5887 5888sub tr_decode_byte { 5889 my($table, $flags) = @_; 5890 my $ssize_t = $Config{ptrsize} == 8 ? 'q' : 'l'; 5891 my ($size, @table) = unpack("${ssize_t}s*", $table); 5892 pop @table; # remove the wildcard final entry 5893 5894 my($c, $tr, @from, @to, @delfrom, $delhyphen); 5895 if ($table[ord "-"] != -1 and 5896 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1) 5897 { 5898 $tr = $table[ord "-"]; 5899 $table[ord "-"] = -1; 5900 if ($tr >= 0) { 5901 @from = ord("-"); 5902 @to = $tr; 5903 } else { # -2 ==> delete 5904 $delhyphen = 1; 5905 } 5906 } 5907 for ($c = 0; $c < @table; $c++) { 5908 $tr = $table[$c]; 5909 if ($tr >= 0) { 5910 push @from, $c; push @to, $tr; 5911 } elsif ($tr == -2) { 5912 push @delfrom, $c; 5913 } 5914 } 5915 @from = (@from, @delfrom); 5916 5917 if ($flags & OPpTRANS_COMPLEMENT) { 5918 unless ($flags & OPpTRANS_DELETE) { 5919 @to = () if ("@from" eq "@to"); 5920 } 5921 5922 my @newfrom = (); 5923 my %from; 5924 @from{@from} = (1) x @from; 5925 for ($c = 0; $c < 256; $c++) { 5926 push @newfrom, $c unless $from{$c}; 5927 } 5928 @from = @newfrom; 5929 } 5930 unless ($flags & OPpTRANS_DELETE || !@to) { 5931 pop @to while $#to and $to[$#to] == $to[$#to -1]; 5932 } 5933 my($from, $to); 5934 $from = collapse(@from); 5935 $to = collapse(@to); 5936 $from .= "-" if $delhyphen; 5937 return ($from, $to); 5938} 5939 5940my $infinity = ~0 >> 1; # IV_MAX 5941 5942sub tr_append_to_invlist { 5943 my ($list_ref, $current, $next) = @_; 5944 5945 # Appends the range $current..$next-1 to the inversion list $list_ref 5946 5947 printf STDERR "%d: %d..%d %s", __LINE__, $current, $next, Dumper $list_ref if DEBUG; 5948 5949 if (@$list_ref && $list_ref->[-1] == $current) { 5950 5951 # The new range extends the current final one. If it is a finite 5952 # rane, replace the current final by the new ending. 5953 if (defined $next) { 5954 $list_ref->[-1] = $next; 5955 } 5956 else { 5957 # The new range extends to infinity, which means the current end 5958 # of the inversion list is dangling. Removing it causes things to 5959 # work. 5960 pop @$list_ref; 5961 } 5962 } 5963 else { # The new range starts after the current final one; add it as a 5964 # new range 5965 push @$list_ref, $current; 5966 push @$list_ref, $next if defined $next; 5967 } 5968 5969 print STDERR __LINE__, ": ", Dumper $list_ref if DEBUG; 5970} 5971 5972sub tr_invlist_to_string { 5973 my ($list_ref, $to_complement) = @_; 5974 5975 # Stringify the inversion list $list_ref, possibly complementing it first. 5976 # CAUTION: this can modify $list_ref. 5977 5978 print STDERR __LINE__, ": ", Dumper $list_ref if DEBUG; 5979 5980 if ($to_complement) { 5981 5982 # Complementing an inversion list is done by prepending a 0 if it 5983 # doesn't have one there already; otherwise removing the leading 0. 5984 if ($list_ref->[0] == 0) { 5985 shift @$list_ref; 5986 } 5987 else { 5988 unshift @$list_ref, 0; 5989 } 5990 5991 print STDERR __LINE__, ": ", Dumper $list_ref if DEBUG; 5992 } 5993 5994 my $output = ""; 5995 5996 # Every other element is in the list. 5997 for (my $i = 0; $i < @$list_ref; $i += 2) { 5998 my $base = $list_ref->[$i]; 5999 $output .= pchr($base); 6000 last unless defined $list_ref->[$i+1]; 6001 6002 # The beginning of the next element starts the range of items not in 6003 # the list. 6004 my $upper = $list_ref->[$i+1] - 1; 6005 my $range = $upper - $base; 6006 $output .= '-' if $range > 1; # Adjacent characters don't have a 6007 # minus, though it would be legal to do 6008 # so 6009 $output .= pchr($upper) if $range > 0; 6010 } 6011 6012 print STDERR __LINE__, ": tr_invlist_to_string() returning '$output'\n" 6013 if DEBUG; 6014 return $output; 6015} 6016 6017my $unmapped = ~0; 6018my $special_handling = ~0 - 1; 6019 6020sub dump_invmap { 6021 my ($invlist_ref, $map_ref) = @_; 6022 6023 for my $i (0 .. @$invlist_ref - 1) { 6024 printf STDERR "[%d]\t%x\t", $i, $invlist_ref->[$i]; 6025 my $map = $map_ref->[$i]; 6026 if ($map == $unmapped) { 6027 print STDERR "TR_UNMAPPED\n"; 6028 } 6029 elsif ($map == $special_handling) { 6030 print STDERR "TR_SPECIAL\n"; 6031 } 6032 else { 6033 printf STDERR "%x\n", $map; 6034 } 6035 } 6036} 6037 6038sub tr_decode_utf8 { 6039 my($tr_av, $flags) = @_; 6040 6041 printf STDERR "\n%s: %d: flags=0x%x\n", __FILE__, __LINE__, $flags if DEBUG; 6042 6043 my $invlist = $tr_av->ARRAYelt(0); 6044 my @invlist = unpack("J*", $invlist->PV); 6045 my @map = unpack("J*", $tr_av->ARRAYelt(1)->PV); 6046 6047 dump_invmap(\@invlist, \@map) if DEBUG; 6048 6049 my @from; 6050 my @to; 6051 6052 # Go through the whole map 6053 for (my $i = 0; $i < @invlist; $i++) { 6054 my $map = $map[$i]; 6055 printf STDERR "%d: i=%d, source=%x, map=%x\n", 6056 __LINE__, $i, $invlist[$i], $map if DEBUG; 6057 6058 # Ignore any lines that are unmapped 6059 next if $map == $unmapped; 6060 6061 # Calculate this component of the mapping; First the lhs 6062 my $this_from = $invlist[$i]; 6063 my $next_from = $invlist[$i+1] if $i < @invlist - 1; 6064 6065 # The length of the rhs is the same as the lhs, except when special 6066 my $next_map = $map - $this_from + $next_from 6067 if $map != $special_handling && defined $next_from; 6068 6069 if (DEBUG) { 6070 printf STDERR "%d: i=%d, from=%x, to=%x", 6071 __LINE__, $i, $this_from, $map; 6072 printf STDERR ", next_from=%x,", $next_from if defined $next_from; 6073 printf STDERR ", next_map=%x", $next_map if defined $next_map; 6074 print STDERR "\n"; 6075 } 6076 6077 # Add the lhs. 6078 tr_append_to_invlist(\@from, $this_from, $next_from); 6079 6080 # And, the rhs; special handling doesn't get output as it really is an 6081 # unmatched rhs 6082 tr_append_to_invlist(\@to, $map, $next_map) if $map != $special_handling; 6083 } 6084 6085 # Done with the input. 6086 6087 my $to; 6088 if (join("", @from) eq join("", @to)) { 6089 6090 # the rhs is suppressed if identical to the left. That's because 6091 # tr/ABC/ABC/ can be written as tr/ABC//. (Do this comparison before 6092 # any complementing) 6093 $to = ""; 6094 } 6095 else { 6096 $to = tr_invlist_to_string(\@to, 0); # rhs not complemented 6097 } 6098 6099 my $from = tr_invlist_to_string(\@from, 6100 ($flags & OPpTRANS_COMPLEMENT) != 0); 6101 6102 print STDERR "Returning ", escape_str($from), "/", 6103 escape_str($to), "\n" if DEBUG; 6104 return (escape_str($from), escape_str($to)); 6105} 6106 6107sub pp_trans { 6108 my $self = shift; 6109 my($op, $cx, $morflags) = @_; 6110 my($from, $to); 6111 my $class = class($op); 6112 my $priv_flags = $op->private; 6113 if ($class eq "PVOP") { 6114 ($from, $to) = tr_decode_byte($op->pv, $priv_flags); 6115 } elsif ($class eq "PADOP") { 6116 ($from, $to) 6117 = tr_decode_utf8($self->padval($op->padix), $priv_flags); 6118 } else { # class($op) eq "SVOP" 6119 ($from, $to) = tr_decode_utf8($op->sv, $priv_flags); 6120 } 6121 my $flags = ""; 6122 $flags .= "c" if $priv_flags & OPpTRANS_COMPLEMENT; 6123 $flags .= "d" if $priv_flags & OPpTRANS_DELETE; 6124 $to = "" if $from eq $to and $flags eq ""; 6125 $flags .= "s" if $priv_flags & OPpTRANS_SQUASH; 6126 $flags .= $morflags if defined $morflags; 6127 my $ret = $self->keyword("tr") . double_delim($from, $to) . $flags; 6128 if (my $targ = $op->targ) { 6129 return $self->maybe_parens($self->padname($targ) . " =~ $ret", 6130 $cx, 20); 6131 } 6132 return $ret; 6133} 6134 6135sub pp_transr { push @_, 'r'; goto &pp_trans } 6136 6137# Join two components of a double-quoted re, disambiguating 6138# "${foo}bar", "${foo}{bar}", "${foo}[1]". 6139 6140sub re_dq_disambiguate { 6141 my ($first, $last) = @_; 6142 ($last =~ /^[A-Z\\\^\[\]_?]/ && 6143 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc 6144 || ($last =~ /^[{\[\w_]/ && 6145 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/); 6146 return $first . $last; 6147} 6148 6149# Like dq(), but different 6150sub re_dq { 6151 my $self = shift; 6152 my ($op) = @_; 6153 6154 my $type = $op->name; 6155 if ($type eq "const") { 6156 my $unbacked = re_unback($self->const_sv($op)->as_string); 6157 return re_uninterp(escape_re($unbacked)); 6158 } elsif ($type eq "concat") { 6159 my $first = $self->re_dq($op->first); 6160 my $last = $self->re_dq($op->last); 6161 return re_dq_disambiguate($first, $last); 6162 } elsif ($type eq "multiconcat") { 6163 return $self->do_multiconcat($op, 26, 2); 6164 } elsif ($type eq "uc") { 6165 return '\U' . $self->re_dq($op->first->sibling) . '\E'; 6166 } elsif ($type eq "lc") { 6167 return '\L' . $self->re_dq($op->first->sibling) . '\E'; 6168 } elsif ($type eq "ucfirst") { 6169 return '\u' . $self->re_dq($op->first->sibling); 6170 } elsif ($type eq "lcfirst") { 6171 return '\l' . $self->re_dq($op->first->sibling); 6172 } elsif ($type eq "quotemeta") { 6173 return '\Q' . $self->re_dq($op->first->sibling) . '\E'; 6174 } elsif ($type eq "fc") { 6175 return '\F' . $self->re_dq($op->first->sibling) . '\E'; 6176 } elsif ($type eq "join") { 6177 return $self->deparse($op->last, 26); # was join($", @ary) 6178 } else { 6179 my $ret = $self->deparse($op, 26); 6180 $ret =~ s/^\$([(|)])\z/\${$1}/ # $( $| $) need braces 6181 or $ret =~ s/^\@([-+])\z/\@{$1}/; # @- @+ need braces 6182 return $ret; 6183 } 6184} 6185 6186sub pure_string { 6187 my ($self, $op) = @_; 6188 return 0 if null $op; 6189 my $type = $op->name; 6190 6191 if ($type eq 'const' || $type eq 'av2arylen') { 6192 return 1; 6193 } 6194 elsif ($type =~ /^(?:[ul]c(first)?|fc)$/ || $type eq 'quotemeta') { 6195 return $self->pure_string($op->first->sibling); 6196 } 6197 elsif ($type eq 'join') { 6198 my $join_op = $op->first->sibling; # Skip pushmark 6199 return 0 unless $join_op->name eq 'null' && $join_op->targ == OP_RV2SV; 6200 6201 my $gvop = $join_op->first; 6202 return 0 unless $gvop->name eq 'gvsv'; 6203 return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop)); 6204 6205 return 0 unless ${$join_op->sibling} eq ${$op->last}; 6206 return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/; 6207 } 6208 elsif ($type eq 'concat') { 6209 return $self->pure_string($op->first) 6210 && $self->pure_string($op->last); 6211 } 6212 elsif ($type eq 'multiconcat') { 6213 my ($kid, @kids); 6214 for ($kid = $op->first; !null $kid; $kid = $kid->sibling) { 6215 # skip the consts and/or padsv we've optimised away 6216 push @kids, $kid 6217 unless $kid->type == OP_NULL 6218 && ( $kid->targ == OP_PADSV 6219 || $kid->targ == OP_CONST 6220 || $kid->targ == OP_PUSHMARK); 6221 } 6222 6223 if ($op->flags & OPf_STACKED) { 6224 # remove expr from @kids where 'expr = ...' or 'expr .= ....' 6225 if ($op->private & OPpMULTICONCAT_APPEND) { 6226 shift(@kids); 6227 } 6228 else { 6229 pop(@kids); 6230 } 6231 } 6232 for (@kids) { 6233 return 0 unless $self->pure_string($_); 6234 } 6235 return 1; 6236 } 6237 elsif (is_scalar($op) || $type =~ /^[ah]elem$/) { 6238 return 1; 6239 } 6240 elsif ($type eq "null" and $op->can('first') and not null $op->first) { 6241 my $first = $op->first; 6242 6243 return 1 if $first->name eq "multideref"; 6244 return 1 if $first->name eq "aelemfast_lex"; 6245 6246 if ( $first->name eq "null" 6247 and $first->can('first') 6248 and not null $first->first 6249 and $first->first->name eq "aelemfast" 6250 ) 6251 { 6252 return 1; 6253 } 6254 } 6255 6256 return 0; 6257} 6258 6259sub code_list { 6260 my ($self,$op,$cv) = @_; 6261 6262 # localise stuff relating to the current sub 6263 $cv and 6264 local($self->{'curcv'}) = $cv, 6265 local($self->{'curcvlex'}), 6266 local(@$self{qw'curstash warnings hints hinthash curcop'}) 6267 = @$self{qw'curstash warnings hints hinthash curcop'}; 6268 6269 my $re; 6270 for ($op = $op->first->sibling; !null($op); $op = $op->sibling) { 6271 if ($op->name eq 'null' and $op->flags & OPf_SPECIAL) { 6272 my $scope = $op->first; 6273 # 0 context (last arg to scopeop) means statement context, so 6274 # the contents of the block will not be wrapped in do{...}. 6275 my $block = scopeop($scope->first->name eq "enter", $self, 6276 $scope, 0); 6277 # next op is the source code of the block 6278 $op = $op->sibling; 6279 $re .= ($self->const_sv($op)->PV =~ m|^(\(\?\??\{)|)[0]; 6280 my $multiline = $block =~ /\n/; 6281 $re .= $multiline ? "\n\t" : ' '; 6282 $re .= $block; 6283 $re .= $multiline ? "\n\b})" : " })"; 6284 } else { 6285 $re = re_dq_disambiguate($re, $self->re_dq($op)); 6286 } 6287 } 6288 $re; 6289} 6290 6291sub regcomp { 6292 my $self = shift; 6293 my($op, $cx) = @_; 6294 my $kid = $op->first; 6295 $kid = $kid->first if $kid->name eq "regcmaybe"; 6296 $kid = $kid->first if $kid->name eq "regcreset"; 6297 my $kname = $kid->name; 6298 if ($kname eq "null" and !null($kid->first) 6299 and $kid->first->name eq 'pushmark') 6300 { 6301 my $str = ''; 6302 $kid = $kid->first->sibling; 6303 while (!null($kid)) { 6304 my $first = $str; 6305 my $last = $self->re_dq($kid); 6306 $str = re_dq_disambiguate($first, $last); 6307 $kid = $kid->sibling; 6308 } 6309 return $str, 1; 6310 } 6311 6312 return ($self->re_dq($kid), 1) 6313 if $kname =~ /^(?:rv2|pad)av/ or $self->pure_string($kid); 6314 return ($self->deparse($kid, $cx), 0); 6315} 6316 6317sub pp_regcomp { 6318 my ($self, $op, $cx) = @_; 6319 return (($self->regcomp($op, $cx, 0))[0]); 6320} 6321 6322sub re_flags { 6323 my ($self, $op) = @_; 6324 my $flags = ''; 6325 my $pmflags = $op->pmflags; 6326 if (!$pmflags) { 6327 my $re = $op->pmregexp; 6328 if ($$re) { 6329 $pmflags = $re->compflags; 6330 } 6331 } 6332 $flags .= "g" if $pmflags & PMf_GLOBAL; 6333 $flags .= "i" if $pmflags & PMf_FOLD; 6334 $flags .= "m" if $pmflags & PMf_MULTILINE; 6335 $flags .= "o" if $pmflags & PMf_KEEP; 6336 $flags .= "s" if $pmflags & PMf_SINGLELINE; 6337 $flags .= "x" if $pmflags & PMf_EXTENDED; 6338 $flags .= "x" if $pmflags & PMf_EXTENDED_MORE; 6339 $flags .= "p" if $pmflags & PMf_KEEPCOPY; 6340 $flags .= "n" if $pmflags & PMf_NOCAPTURE; 6341 if (my $charset = $pmflags & PMf_CHARSET) { 6342 # Hardcoding this is fragile, but B does not yet export the 6343 # constants we need. 6344 $flags .= qw(d l u a aa)[$charset >> 7] 6345 } 6346 # The /d flag is indicated by 0; only show it if necessary. 6347 elsif ($self->{hinthash} and 6348 $self->{hinthash}{reflags_charset} 6349 || $self->{hinthash}{feature_unicode} 6350 or $self->{hints} & $feature::hint_mask 6351 && ($self->{hints} & $feature::hint_mask) 6352 != $feature::hint_mask 6353 && $self->{hints} & $feature::hint_uni8bit 6354 ) { 6355 $flags .= 'd'; 6356 } 6357 $flags; 6358} 6359 6360# osmic acid -- see osmium tetroxide 6361 6362my %matchwords; 6363map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs', 6364 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic', 6365 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi', 'soup', 'soupmix'); 6366 6367# When deparsing a regular expression with code blocks, we have to look in 6368# various places to find the blocks. 6369# 6370# For qr/(?{...})/ without interpolation, the CV is under $qr->qr_anoncv 6371# and the code list (list of blocks and constants, maybe vars) is under 6372# $cv->ROOT->first->code_list: 6373# ./perl -Ilib -MB -e 'use O "Concise", B::svref_2object(sub {qr/(?{die})/})->ROOT->first->first->sibling->pmregexp->qr_anoncv->object_2svref' 6374# 6375# For qr/$a(?{...})/ with interpolation, the code list is more accessible, 6376# under $pmop->code_list, but the $cv is something you have to dig for in 6377# the regcomp op���s kids: 6378# ./perl -Ilib -mO=Concise -e 'qr/$a(?{die})/' 6379# 6380# For m// and split //, things are much simpler. There is no CV. The code 6381# list is under $pmop->code_list. 6382 6383sub matchop { 6384 my $self = shift; 6385 my($op, $cx, $name, $delim) = @_; 6386 my $kid = $op->first; 6387 my ($binop, $var, $re) = ("", "", ""); 6388 if ($op->name ne 'split' && $op->flags & OPf_STACKED) { 6389 $binop = 1; 6390 $var = $self->deparse($kid, 20); 6391 $kid = $kid->sibling; 6392 } 6393 # not $name; $name will be 'm' for both match and split 6394 elsif ($op->name eq 'match' and my $targ = $op->targ) { 6395 $binop = 1; 6396 $var = $self->padname($targ); 6397 } 6398 my $quote = 1; 6399 my $pmflags = $op->pmflags; 6400 my $rhs_bound_to_defsv; 6401 my ($cv, $bregexp); 6402 my $have_kid = !null $kid; 6403 # Check for code blocks first 6404 if (not null my $code_list = $op->code_list) { 6405 $re = $self->code_list($code_list, 6406 $op->name eq 'qr' 6407 ? $self->padval( 6408 $kid->first # ex-list 6409 ->first # pushmark 6410 ->sibling # entersub 6411 ->first # ex-list 6412 ->first # pushmark 6413 ->sibling # anoncode 6414 ->targ 6415 ) 6416 : undef); 6417 } elsif (${$bregexp = $op->pmregexp} && ${$cv = $bregexp->qr_anoncv}) { 6418 my $patop = $cv->ROOT # leavesub 6419 ->first # qr 6420 ->code_list;# list 6421 $re = $self->code_list($patop, $cv); 6422 } elsif (!$have_kid) { 6423 $re = re_uninterp(escape_re(re_unback($op->precomp))); 6424 } elsif ($kid->name ne 'regcomp') { 6425 if ($op->name eq 'split') { 6426 # split has other kids, not just regcomp 6427 $re = re_uninterp(escape_re(re_unback($op->precomp))); 6428 } 6429 else { 6430 carp("found ".$kid->name." where regcomp expected"); 6431 } 6432 } else { 6433 ($re, $quote) = $self->regcomp($kid, 21); 6434 } 6435 if ($have_kid and $kid->name eq 'regcomp') { 6436 my $matchop = $kid->first; 6437 if ($matchop->name eq 'regcreset') { 6438 $matchop = $matchop->first; 6439 } 6440 if ($matchop->name =~ /^(?:match|transr?|subst)\z/ 6441 && $matchop->flags & OPf_SPECIAL) { 6442 $rhs_bound_to_defsv = 1; 6443 } 6444 } 6445 my $flags = ""; 6446 $flags .= "c" if $pmflags & PMf_CONTINUE; 6447 $flags .= $self->re_flags($op); 6448 $flags = join '', sort split //, $flags; 6449 $flags = $matchwords{$flags} if $matchwords{$flags}; 6450 if ($pmflags & PMf_ONCE) { # only one kind of delimiter works here 6451 $re =~ s/\?/\\?/g; 6452 $re = $self->keyword("m") . "?$re?"; # explicit 'm' is required 6453 } elsif ($quote) { 6454 $re = single_delim($name, $delim, $re, $self); 6455 } 6456 $re = $re . $flags if $quote; 6457 if ($binop) { 6458 return 6459 $self->maybe_parens( 6460 $rhs_bound_to_defsv 6461 ? "$var =~ (\$_ =~ $re)" 6462 : "$var =~ $re", 6463 $cx, 20 6464 ); 6465 } else { 6466 return $re; 6467 } 6468} 6469 6470sub pp_match { matchop(@_, "m", "/") } 6471sub pp_qr { matchop(@_, "qr", "") } 6472 6473sub pp_runcv { unop(@_, "__SUB__"); } 6474 6475sub pp_split { 6476 my $self = shift; 6477 my($op, $cx) = @_; 6478 my($kid, @exprs, $ary, $expr); 6479 my $stacked = $op->flags & OPf_STACKED; 6480 6481 $kid = $op->first; 6482 $kid = $kid->sibling if $kid->name eq 'regcomp'; 6483 for (; !null($kid); $kid = $kid->sibling) { 6484 push @exprs, $self->deparse($kid, 6); 6485 } 6486 6487 unshift @exprs, $self->matchop($op, $cx, "m", "/"); 6488 6489 if ($op->private & OPpSPLIT_ASSIGN) { 6490 # With C<@array = split(/pat/, str);>, 6491 # array is stored in split's pmreplroot; either 6492 # as an integer index into the pad (for a lexical array) 6493 # or as GV for a package array (which will be a pad index 6494 # on threaded builds) 6495 # With my/our @array = split(/pat/, str), the array is instead 6496 # accessed via an extra padav/rv2av op at the end of the 6497 # split's kid ops. 6498 6499 if ($stacked) { 6500 $ary = pop @exprs; 6501 } 6502 else { 6503 if ($op->private & OPpSPLIT_LEX) { 6504 $ary = $self->padname($op->pmreplroot); 6505 } 6506 else { 6507 # union with op_pmtargetoff, op_pmtargetgv 6508 my $gv = $op->pmreplroot; 6509 $gv = $self->padval($gv) if !ref($gv); 6510 $ary = $self->maybe_local(@_, 6511 $self->stash_variable('@', 6512 $self->gv_name($gv), 6513 $cx)) 6514 } 6515 if ($op->private & OPpLVAL_INTRO) { 6516 $ary = $op->private & OPpSPLIT_LEX ? "my $ary" : "local $ary"; 6517 } 6518 } 6519 } 6520 6521 # handle special case of split(), and split(' ') that compiles to /\s+/ 6522 $exprs[0] = q{' '} if ($op->reflags // 0) & RXf_SKIPWHITE(); 6523 6524 $expr = "split(" . join(", ", @exprs) . ")"; 6525 if ($ary) { 6526 return $self->maybe_parens("$ary = $expr", $cx, 7); 6527 } else { 6528 return $expr; 6529 } 6530} 6531 6532# oxime -- any of various compounds obtained chiefly by the action of 6533# hydroxylamine on aldehydes and ketones and characterized by the 6534# bivalent grouping C=NOH [Webster's Tenth] 6535 6536my %substwords; 6537map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em', 6538 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me', 6539 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem', 6540 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi', 'rogue', 6541 'sir', 'rise', 'smore', 'more', 'seer', 'rome', 'gore', 'grim', 'grime', 6542 'or', 'rose', 'rosie'); 6543 6544sub pp_subst { 6545 my $self = shift; 6546 my($op, $cx) = @_; 6547 my $kid = $op->first; 6548 my($binop, $var, $re, $repl) = ("", "", "", ""); 6549 if ($op->flags & OPf_STACKED) { 6550 $binop = 1; 6551 $var = $self->deparse($kid, 20); 6552 $kid = $kid->sibling; 6553 } 6554 elsif (my $targ = $op->targ) { 6555 $binop = 1; 6556 $var = $self->padname($targ); 6557 } 6558 my $flags = ""; 6559 my $pmflags = $op->pmflags; 6560 if (null($op->pmreplroot)) { 6561 $repl = $kid; 6562 $kid = $kid->sibling; 6563 } else { 6564 $repl = $op->pmreplroot->first; # skip substcont 6565 } 6566 while ($repl->name eq "entereval") { 6567 $repl = $repl->first; 6568 $flags .= "e"; 6569 } 6570 { 6571 local $self->{in_subst_repl} = 1; 6572 if ($pmflags & PMf_EVAL) { 6573 $repl = $self->deparse($repl->first, 0); 6574 } else { 6575 $repl = $self->dq($repl); 6576 } 6577 } 6578 if (not null my $code_list = $op->code_list) { 6579 $re = $self->code_list($code_list); 6580 } elsif (null $kid) { 6581 $re = re_uninterp(escape_re(re_unback($op->precomp))); 6582 } else { 6583 ($re) = $self->regcomp($kid, 1); 6584 } 6585 $flags .= "r" if $pmflags & PMf_NONDESTRUCT; 6586 $flags .= "e" if $pmflags & PMf_EVAL; 6587 $flags .= $self->re_flags($op); 6588 $flags = join '', sort split //, $flags; 6589 $flags = $substwords{$flags} if $substwords{$flags}; 6590 my $core_s = $self->keyword("s"); # maybe CORE::s 6591 if ($binop) { 6592 return $self->maybe_parens("$var =~ $core_s" 6593 . double_delim($re, $repl) . $flags, 6594 $cx, 20); 6595 } else { 6596 return "$core_s". double_delim($re, $repl) . $flags; 6597 } 6598} 6599 6600sub is_lexical_subs { 6601 my (@ops) = shift; 6602 for my $op (@ops) { 6603 return 0 if $op->name !~ /\A(?:introcv|clonecv)\z/; 6604 } 6605 return 1; 6606} 6607 6608# Pretend these two ops do not exist. The perl parser adds them to the 6609# beginning of any block containing my-sub declarations, whereas we handle 6610# the subs in pad_subs and next_todo. 6611*pp_clonecv = *pp_introcv; 6612sub pp_introcv { 6613 my $self = shift; 6614 my($op, $cx) = @_; 6615 # For now, deparsing doesn't worry about the distinction between introcv 6616 # and clonecv, so pretend this op doesn't exist: 6617 return ''; 6618} 6619 6620sub pp_padcv { 6621 my $self = shift; 6622 my($op, $cx) = @_; 6623 return $self->padany($op); 6624} 6625 6626my %lvref_funnies = ( 6627 OPpLVREF_SV, => '$', 6628 OPpLVREF_AV, => '@', 6629 OPpLVREF_HV, => '%', 6630 OPpLVREF_CV, => '&', 6631); 6632 6633sub pp_refassign { 6634 my ($self, $op, $cx) = @_; 6635 my $left; 6636 if ($op->private & OPpLVREF_ELEM) { 6637 $left = $op->first->sibling; 6638 $left = maybe_local(@_, elem($self, $left, undef, 6639 $left->targ == OP_AELEM 6640 ? qw([ ] padav) 6641 : qw({ } padhv))); 6642 } elsif ($op->flags & OPf_STACKED) { 6643 $left = maybe_local(@_, 6644 $lvref_funnies{$op->private & OPpLVREF_TYPE} 6645 . $self->deparse($op->first->sibling)); 6646 } else { 6647 $left = &pp_padsv; 6648 } 6649 my $right = $self->deparse_binop_right($op, $op->first, 7); 6650 return $self->maybe_parens("\\$left = $right", $cx, 7); 6651} 6652 6653sub pp_lvref { 6654 my ($self, $op, $cx) = @_; 6655 my $code; 6656 if ($op->private & OPpLVREF_ELEM) { 6657 $code = $op->first->name =~ /av\z/ ? &pp_aelem : &pp_helem; 6658 } elsif ($op->flags & OPf_STACKED) { 6659 $code = maybe_local(@_, 6660 $lvref_funnies{$op->private & OPpLVREF_TYPE} 6661 . $self->deparse($op->first)); 6662 } else { 6663 $code = &pp_padsv; 6664 } 6665 "\\$code"; 6666} 6667 6668sub pp_lvrefslice { 6669 my ($self, $op, $cx) = @_; 6670 '\\' . ($op->last->name =~ /av\z/ ? &pp_aslice : &pp_hslice); 6671} 6672 6673sub pp_lvavref { 6674 my ($self, $op, $cx) = @_; 6675 '\\(' . ($op->flags & OPf_STACKED 6676 ? maybe_local(@_, rv2x(@_, "\@")) 6677 : &pp_padsv) . ')' 6678} 6679 6680 6681sub pp_argcheck { 6682 my $self = shift; 6683 my($op, $cx) = @_; 6684 my ($params, $opt_params, $slurpy) = $op->aux_list($self->{curcv}); 6685 my $mandatory = $params - $opt_params; 6686 my $check = ''; 6687 6688 $check .= <<EOF if !$slurpy; 6689die sprintf("Too many arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ <= $params; 6690EOF 6691 6692 $check .= <<EOF if $mandatory > 0; 6693die sprintf("Too few arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ >= $mandatory; 6694EOF 6695 6696 my $cond = ($params & 1) ? 'unless' : 'if'; 6697 $check .= <<EOF if $slurpy eq '%'; 6698die sprintf("Odd name/value argument for subroutine at %s line %d.\\n", (caller)[1, 2]) if \@_ > $params && ((\@_ - $params) & 1); 6699EOF 6700 6701 $check =~ s/;\n\z//; 6702 return $check; 6703} 6704 6705 6706sub pp_argelem { 6707 my $self = shift; 6708 my($op, $cx) = @_; 6709 my $var = $self->padname($op->targ); 6710 my $ix = $op->string($self->{curcv}); 6711 my $expr; 6712 if ($op->flags & OPf_KIDS) { 6713 $expr = $self->deparse($op->first, 7); 6714 } 6715 elsif ($var =~ /^[@%]/) { 6716 $expr = $ix ? "\@_[$ix .. \$#_]" : '@_'; 6717 } 6718 else { 6719 $expr = "\$_[$ix]"; 6720 } 6721 return "my $var = $expr"; 6722} 6723 6724 6725sub pp_argdefelem { 6726 my $self = shift; 6727 my($op, $cx) = @_; 6728 my $ix = $op->targ; 6729 my $expr = "\@_ >= " . ($ix+1) . " ? \$_[$ix] : "; 6730 my $def = $self->deparse($op->first, 7); 6731 $def = "($def)" if $op->first->flags & OPf_PARENS; 6732 $expr .= $self->deparse($op->first, $cx); 6733 return $expr; 6734} 6735 6736 6737sub pp_pushdefer { 6738 my $self = shift; 6739 my($op, $cx) = @_; 6740 # defer block body is stored in the ->first of an OP_NULL that is 6741 # ->first of OP_PUSHDEFER 6742 my $body = $self->deparse($op->first->first); 6743 return "defer {\n\t$body\n\b}\cK"; 6744} 6745 6746sub builtin1 { 6747 my $self = shift; 6748 my ($op, $cx, $name) = @_; 6749 my $arg = $self->deparse($op->first); 6750 # TODO: work out if lexical alias is present somehow... 6751 return "builtin::$name($arg)"; 6752} 6753 6754sub pp_is_bool { builtin1(@_, "is_bool"); } 6755sub pp_is_weak { builtin1(@_, "is_weak"); } 6756sub pp_weaken { builtin1(@_, "weaken"); } 6757sub pp_unweaken { builtin1(@_, "unweaken"); } 6758sub pp_blessed { builtin1(@_, "blessed"); } 6759sub pp_refaddr { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "refaddr"); } 6760sub pp_reftype { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "reftype"); } 6761sub pp_ceil { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "ceil"); } 6762sub pp_floor { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "floor"); } 6763sub pp_is_tainted { builtin1(@_, "is_tainted"); } 6764 67651; 6766__END__ 6767 6768=head1 NAME 6769 6770B::Deparse - Perl compiler backend to produce perl code 6771 6772=head1 SYNOPSIS 6773 6774B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>] 6775 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl> 6776 6777=head1 DESCRIPTION 6778 6779B::Deparse is a backend module for the Perl compiler that generates 6780perl source code, based on the internal compiled structure that perl 6781itself creates after parsing a program. The output of B::Deparse won't 6782be exactly the same as the original source, since perl doesn't keep 6783track of comments or whitespace, and there isn't a one-to-one 6784correspondence between perl's syntactical constructions and their 6785compiled form, but it will often be close. When you use the B<-p> 6786option, the output also includes parentheses even when they are not 6787required by precedence, which can make it easy to see if perl is 6788parsing your expressions the way you intended. 6789 6790While B::Deparse goes to some lengths to try to figure out what your 6791original program was doing, some parts of the language can still trip 6792it up; it still fails even on some parts of Perl's own test suite. If 6793you encounter a failure other than the most common ones described in 6794the BUGS section below, you can help contribute to B::Deparse's 6795ongoing development by submitting a bug report with a small 6796example. 6797 6798=head1 OPTIONS 6799 6800As with all compiler backend options, these must follow directly after 6801the '-MO=Deparse', separated by a comma but not any white space. 6802 6803=over 4 6804 6805=item B<-d> 6806 6807Output data values (when they appear as constants) using Data::Dumper. 6808Without this option, B::Deparse will use some simple routines of its 6809own for the same purpose. Currently, Data::Dumper is better for some 6810kinds of data (such as complex structures with sharing and 6811self-reference) while the built-in routines are better for others 6812(such as odd floating-point values). 6813 6814=item B<-f>I<FILE> 6815 6816Normally, B::Deparse deparses the main code of a program, and all the subs 6817defined in the same file. To include subs defined in 6818other files, pass the B<-f> option with the filename. 6819You can pass the B<-f> option several times, to 6820include more than one secondary file. (Most of the time you don't want to 6821use it at all.) You can also use this option to include subs which are 6822defined in the scope of a B<#line> directive with two parameters. 6823 6824=item B<-l> 6825 6826Add '#line' declarations to the output based on the line and file 6827locations of the original code. 6828 6829=item B<-p> 6830 6831Print extra parentheses. Without this option, B::Deparse includes 6832parentheses in its output only when they are needed, based on the 6833structure of your program. With B<-p>, it uses parentheses (almost) 6834whenever they would be legal. This can be useful if you are used to 6835LISP, or if you want to see how perl parses your input. If you say 6836 6837 if ($var & 0x7f == 65) {print "Gimme an A!"} 6838 print ($which ? $a : $b), "\n"; 6839 $name = $ENV{USER} or "Bob"; 6840 6841C<B::Deparse,-p> will print 6842 6843 if (($var & 0)) { 6844 print('Gimme an A!') 6845 }; 6846 (print(($which ? $a : $b)), '???'); 6847 (($name = $ENV{'USER'}) or '???') 6848 6849which probably isn't what you intended (the C<'???'> is a sign that 6850perl optimized away a constant value). 6851 6852=item B<-P> 6853 6854Disable prototype checking. With this option, all function calls are 6855deparsed as if no prototype was defined for them. In other words, 6856 6857 perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x' 6858 6859will print 6860 6861 sub foo (\@) { 6862 1; 6863 } 6864 &foo(\@x); 6865 6866making clear how the parameters are actually passed to C<foo>. 6867 6868=item B<-q> 6869 6870Expand double-quoted strings into the corresponding combinations of 6871concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For 6872instance, print 6873 6874 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!"; 6875 6876as 6877 6878 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', ' 6879 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!'); 6880 6881Note that the expanded form represents the way perl handles such 6882constructions internally -- this option actually turns off the reverse 6883translation that B::Deparse usually does. On the other hand, note that 6884C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value 6885of $y into a string before doing the assignment. 6886 6887=item B<-s>I<LETTERS> 6888 6889Tweak the style of B::Deparse's output. The letters should follow 6890directly after the 's', with no space or punctuation. The following 6891options are available: 6892 6893=over 4 6894 6895=item B<C> 6896 6897Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print 6898 6899 if (...) { 6900 ... 6901 } else { 6902 ... 6903 } 6904 6905instead of 6906 6907 if (...) { 6908 ... 6909 } 6910 else { 6911 ... 6912 } 6913 6914The default is not to cuddle. 6915 6916=item B<i>I<NUMBER> 6917 6918Indent lines by multiples of I<NUMBER> columns. The default is 4 columns. 6919 6920=item B<T> 6921 6922Use tabs for each 8 columns of indent. The default is to use only spaces. 6923For instance, if the style options are B<-si4T>, a line that's indented 69243 times will be preceded by one tab and four spaces; if the options were 6925B<-si8T>, the same line would be preceded by three tabs. 6926 6927=item B<v>I<STRING>B<.> 6928 6929Print I<STRING> for the value of a constant that can't be determined 6930because it was optimized away (mnemonic: this happens when a constant 6931is used in B<v>oid context). The end of the string is marked by a period. 6932The string should be a valid perl expression, generally a constant. 6933Note that unless it's a number, it probably needs to be quoted, and on 6934a command line quotes need to be protected from the shell. Some 6935conventional values include 0, 1, 42, '', 'foo', and 6936'Useless use of constant omitted' (which may need to be 6937B<-sv"'Useless use of constant omitted'."> 6938or something similar depending on your shell). The default is '???'. 6939If you're using B::Deparse on a module or other file that's require'd, 6940you shouldn't use a value that evaluates to false, since the customary 6941true constant at the end of a module will be in void context when the 6942file is compiled as a main program. 6943 6944=back 6945 6946=item B<-x>I<LEVEL> 6947 6948Expand conventional syntax constructions into equivalent ones that expose 6949their internal operation. I<LEVEL> should be a digit, with higher values 6950meaning more expansion. As with B<-q>, this actually involves turning off 6951special cases in B::Deparse's normal operations. 6952 6953If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent 6954while loops with continue blocks; for instance 6955 6956 for ($i = 0; $i < 10; ++$i) { 6957 print $i; 6958 } 6959 6960turns into 6961 6962 $i = 0; 6963 while ($i < 10) { 6964 print $i; 6965 } continue { 6966 ++$i 6967 } 6968 6969Note that in a few cases this translation can't be perfectly carried back 6970into the source code -- if the loop's initializer declares a my variable, 6971for instance, it won't have the correct scope outside of the loop. 6972 6973If I<LEVEL> is at least 5, C<use> declarations will be translated into 6974C<BEGIN> blocks containing calls to C<require> and C<import>; for 6975instance, 6976 6977 use strict 'refs'; 6978 6979turns into 6980 6981 sub BEGIN { 6982 require strict; 6983 do { 6984 'strict'->import('refs') 6985 }; 6986 } 6987 6988If I<LEVEL> is at least 7, C<if> statements will be translated into 6989equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance 6990 6991 print 'hi' if $nice; 6992 if ($nice) { 6993 print 'hi'; 6994 } 6995 if ($nice) { 6996 print 'hi'; 6997 } else { 6998 print 'bye'; 6999 } 7000 7001turns into 7002 7003 $nice and print 'hi'; 7004 $nice and do { print 'hi' }; 7005 $nice ? do { print 'hi' } : do { print 'bye' }; 7006 7007Long sequences of elsifs will turn into nested ternary operators, which 7008B::Deparse doesn't know how to indent nicely. 7009 7010=back 7011 7012=head1 USING B::Deparse AS A MODULE 7013 7014=head2 Synopsis 7015 7016 use B::Deparse; 7017 $deparse = B::Deparse->new("-p", "-sC"); 7018 $body = $deparse->coderef2text(\&func); 7019 eval "sub func $body"; # the inverse operation 7020 7021=head2 Description 7022 7023B::Deparse can also be used on a sub-by-sub basis from other perl 7024programs. 7025 7026=head2 new 7027 7028 $deparse = B::Deparse->new(OPTIONS) 7029 7030Create an object to store the state of a deparsing operation and any 7031options. The options are the same as those that can be given on the 7032command line (see L</OPTIONS>); options that are separated by commas 7033after B<-MO=Deparse> should be given as separate strings. 7034 7035=head2 ambient_pragmas 7036 7037 $deparse->ambient_pragmas(strict => 'all', '$[' => $[); 7038 7039The compilation of a subroutine can be affected by a few compiler 7040directives, B<pragmas>. These are: 7041 7042=over 4 7043 7044=item * 7045 7046use strict; 7047 7048=item * 7049 7050use warnings; 7051 7052=item * 7053 7054Assigning to the special variable $[ 7055 7056=item * 7057 7058use integer; 7059 7060=item * 7061 7062use bytes; 7063 7064=item * 7065 7066use utf8; 7067 7068=item * 7069 7070use re; 7071 7072=back 7073 7074Ordinarily, if you use B::Deparse on a subroutine which has 7075been compiled in the presence of one or more of these pragmas, 7076the output will include statements to turn on the appropriate 7077directives. So if you then compile the code returned by coderef2text, 7078it will behave the same way as the subroutine which you deparsed. 7079 7080However, you may know that you intend to use the results in a 7081particular context, where some pragmas are already in scope. In 7082this case, you use the B<ambient_pragmas> method to describe the 7083assumptions you wish to make. 7084 7085Not all of the options currently have any useful effect. See 7086L</BUGS> for more details. 7087 7088The parameters it accepts are: 7089 7090=over 4 7091 7092=item strict 7093 7094Takes a string, possibly containing several values separated 7095by whitespace. The special values "all" and "none" mean what you'd 7096expect. 7097 7098 $deparse->ambient_pragmas(strict => 'subs refs'); 7099 7100=item $[ 7101 7102Takes a number, the value of the array base $[. 7103Obsolete: cannot be non-zero. 7104 7105=item bytes 7106 7107=item utf8 7108 7109=item integer 7110 7111If the value is true, then the appropriate pragma is assumed to 7112be in the ambient scope, otherwise not. 7113 7114=item re 7115 7116Takes a string, possibly containing a whitespace-separated list of 7117values. The values "all" and "none" are special. It's also permissible 7118to pass an array reference here. 7119 7120 $deparser->ambient_pragmas(re => 'eval'); 7121 7122 7123=item warnings 7124 7125Takes a string, possibly containing a whitespace-separated list of 7126values. The values "all" and "none" are special, again. It's also 7127permissible to pass an array reference here. 7128 7129 $deparser->ambient_pragmas(warnings => [qw[void io]]); 7130 7131If one of the values is the string "FATAL", then all the warnings 7132in that list will be considered fatal, just as with the B<warnings> 7133pragma itself. Should you need to specify that some warnings are 7134fatal, and others are merely enabled, you can pass the B<warnings> 7135parameter twice: 7136 7137 $deparser->ambient_pragmas( 7138 warnings => 'all', 7139 warnings => [FATAL => qw/void io/], 7140 ); 7141 7142See L<warnings> for more information about lexical warnings. 7143 7144=item hint_bits 7145 7146=item warning_bits 7147 7148These two parameters are used to specify the ambient pragmas in 7149the format used by the special variables $^H and ${^WARNING_BITS}. 7150 7151They exist principally so that you can write code like: 7152 7153 { my ($hint_bits, $warning_bits); 7154 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})} 7155 $deparser->ambient_pragmas ( 7156 hint_bits => $hint_bits, 7157 warning_bits => $warning_bits, 7158 '$[' => 0 + $[ 7159 ); } 7160 7161which specifies that the ambient pragmas are exactly those which 7162are in scope at the point of calling. 7163 7164=item %^H 7165 7166This parameter is used to specify the ambient pragmas which are 7167stored in the special hash %^H. 7168 7169=back 7170 7171=head2 coderef2text 7172 7173 $body = $deparse->coderef2text(\&func) 7174 $body = $deparse->coderef2text(sub ($$) { ... }) 7175 7176Return source code for the body of a subroutine (a block, optionally 7177preceded by a prototype in parens), given a reference to the 7178sub. Because a subroutine can have no names, or more than one name, 7179this method doesn't return a complete subroutine definition -- if you 7180want to eval the result, you should prepend "sub subname ", or "sub " 7181for an anonymous function constructor. Unless the sub was defined in 7182the main:: package, the code will include a package declaration. 7183 7184=head1 BUGS 7185 7186=over 4 7187 7188=item * 7189 7190The only pragmas to 7191be completely supported are: C<use warnings>, 7192C<use strict>, C<use bytes>, C<use integer> 7193and C<use feature>. 7194 7195Excepting those listed above, we're currently unable to guarantee that 7196B::Deparse will produce a pragma at the correct point in the program. 7197(Specifically, pragmas at the beginning of a block often appear right 7198before the start of the block instead.) 7199Since the effects of pragmas are often lexically scoped, this can mean 7200that the pragma holds sway over a different portion of the program 7201than in the input file. 7202 7203=item * 7204 7205In fact, the above is a specific instance of a more general problem: 7206we can't guarantee to produce BEGIN blocks or C<use> declarations in 7207exactly the right place. So if you use a module which affects compilation 7208(such as by over-riding keywords, overloading constants or whatever) 7209then the output code might not work as intended. 7210 7211=item * 7212 7213Some constants don't print correctly either with or without B<-d>. 7214For instance, neither B::Deparse nor Data::Dumper know how to print 7215dual-valued scalars correctly, as in: 7216 7217 use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y; 7218 7219 use constant H => { "#" => 1 }; H->{"#"}; 7220 7221=item * 7222 7223An input file that uses source filtering probably won't be deparsed into 7224runnable code, because it will still include the B<use> declaration 7225for the source filtering module, even though the code that is 7226produced is already ordinary Perl which shouldn't be filtered again. 7227 7228=item * 7229 7230Optimized-away statements are rendered as 7231'???'. This includes statements that 7232have a compile-time side-effect, such as the obscure 7233 7234 my $x if 0; 7235 7236which is not, consequently, deparsed correctly. 7237 7238 foreach my $i (@_) { 0 } 7239 => 7240 foreach my $i (@_) { '???' } 7241 7242=item * 7243 7244Lexical (my) variables declared in scopes external to a subroutine 7245appear in coderef2text output text as package variables. This is a tricky 7246problem, as perl has no native facility for referring to a lexical variable 7247defined within a different scope, although L<PadWalker> is a good start. 7248 7249See also L<Data::Dump::Streamer>, which combines B::Deparse and 7250L<PadWalker> to serialize closures properly. 7251 7252=item * 7253 7254There are probably many more bugs on non-ASCII platforms (EBCDIC). 7255 7256=back 7257 7258=head1 AUTHOR 7259 7260Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version 7261by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from 7262Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell, 7263Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael 7264Garcia-Suarez. 7265 7266=cut 7267