This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
VMS does have fsync, so configure accordingly.
[perl5.git] / lib / B / Deparse.pm
CommitLineData
6e90668e 1# B::Deparse.pm
4ca8de37
SM
2# Copyright (c) 1998-2000, 2002, 2003, 2004, 2005, 2006 Stephen McCamant.
3# All rights reserved.
6e90668e
SM
4# This module is free software; you can redistribute and/or modify
5# it under the same terms as Perl itself.
6
7# This is based on the module of the same name by Malcolm Beattie,
8# but essentially none of his code remains.
9
a798dbf2 10package B::Deparse;
ff97752d 11use Carp;
51a5edaf 12use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
bd0865ec 13 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
c8ec376c 14 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPf_PARENS
ce4e655d 15 OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
3ed82cfc 16 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
5e462669 17 OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST
fedf30e1 18 OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE
d989cdac 19 SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
56cd2ef8 20 SVpad_TYPED
e95ab0c0 21 CVf_METHOD CVf_LVALUE
2be95ceb 22 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
fedf30e1
DM
23 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED PMf_EXTENDED_MORE
24 MDEREF_reload
25 MDEREF_AV_pop_rv2av_aelem
26 MDEREF_AV_gvsv_vivify_rv2av_aelem
27 MDEREF_AV_padsv_vivify_rv2av_aelem
28 MDEREF_AV_vivify_rv2av_aelem
29 MDEREF_AV_padav_aelem
30 MDEREF_AV_gvav_aelem
31 MDEREF_HV_pop_rv2hv_helem
32 MDEREF_HV_gvsv_vivify_rv2hv_helem
33 MDEREF_HV_padsv_vivify_rv2hv_helem
34 MDEREF_HV_vivify_rv2hv_helem
35 MDEREF_HV_padhv_helem
36 MDEREF_HV_gvhv_helem
37 MDEREF_ACTION_MASK
38 MDEREF_INDEX_none
39 MDEREF_INDEX_const
40 MDEREF_INDEX_padsv
41 MDEREF_INDEX_gvsv
42 MDEREF_INDEX_MASK
43 MDEREF_FLAG_last
44 MDEREF_MASK
45 MDEREF_SHIFT
46 );
47
59f8d31d 48$VERSION = '1.31';
a798dbf2 49use strict;
2ae48fff 50use vars qw/$AUTOLOAD/;
34a48b4b 51use warnings ();
149758b3 52require feature;
a798dbf2 53
aa381260 54BEGIN {
ff0cf12f 55 # List version-specific constants here.
2be95ceb
NC
56 # Easiest way to keep this code portable between version looks to
57 # be to fake up a dummy constant that will never actually be true.
58 foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
ff0cf12f 59 OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE
b9bc576f 60 RXf_PMf_CHARSET RXf_PMf_KEEPCOPY
24fcb59f 61 CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
bcff4148 62 PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES
9187b6e4
FC
63 OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV
64 OPpLVREF_CV OPpLVREF_ELEM SVpad_STATE)) {
ff0cf12f 65 eval { import B $_ };
2be95ceb
NC
66 no strict 'refs';
67 *{$_} = sub () {0} unless *{$_}{CODE};
68 }
aa381260
NC
69}
70
6e90668e
SM
71# Changes between 0.50 and 0.51:
72# - fixed nulled leave with live enter in sort { }
73# - fixed reference constants (\"str")
74# - handle empty programs gracefully
c4a6f826 75# - handle infinite loops (for (;;) {}, while (1) {})
e38ccfd9 76# - differentiate between 'for my $x ...' and 'my $x; for $x ...'
6e90668e
SM
77# - various minor cleanups
78# - moved globals into an object
e38ccfd9 79# - added '-u', like B::C
6e90668e
SM
80# - package declarations using cop_stash
81# - subs, formats and code sorted by cop_seq
f6f9bdb7 82# Changes between 0.51 and 0.52:
4d1ff10f 83# - added pp_threadsv (special variables under USE_5005THREADS)
f6f9bdb7 84# - added documentation
bd0865ec 85# Changes between 0.52 and 0.53:
9d2c6865 86# - many changes adding precedence contexts and associativity
e38ccfd9 87# - added '-p' and '-s' output style options
9d2c6865 88# - various other minor fixes
bd0865ec 89# Changes between 0.53 and 0.54:
e38ccfd9 90# - added support for new 'for (1..100)' optimization,
d7f5b6da 91# thanks to Gisle Aas
bd0865ec 92# Changes between 0.54 and 0.55:
90be192f
SM
93# - added support for new qr// construct
94# - added support for new pp_regcreset OP
bd0865ec 95# Changes between 0.55 and 0.56:
f5aa8f4e
SM
96# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
97# - fixed $# on non-lexicals broken in last big rewrite
98# - added temporary fix for change in opcode of OP_STRINGIFY
e38ccfd9 99# - fixed problem in 0.54's for() patch in 'for (@ary)'
f5aa8f4e 100# - fixed precedence in conditional of ?:
e38ccfd9 101# - tweaked list paren elimination in 'my($x) = @_'
f5aa8f4e
SM
102# - made continue-block detection trickier wrt. null ops
103# - fixed various prototype problems in pp_entersub
104# - added support for sub prototypes that never get GVs
105# - added unquoting for special filehandle first arg in truncate
e38ccfd9 106# - print doubled rv2gv (a bug) as '*{*GV}' instead of illegal '**GV'
f5aa8f4e 107# - added semicolons at the ends of blocks
e38ccfd9 108# - added -l '#line' declaration option -- fixes cmd/subval.t 27,28
bd0865ec
GS
109# Changes between 0.56 and 0.561:
110# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
111# - used new B.pm symbolic constants (done by Nick Ing-Simmons)
112# Changes between 0.561 and 0.57:
113# - stylistic changes to symbolic constant stuff
114# - handled scope in s///e replacement code
115# - added unquote option for expanding "" into concats, etc.
116# - split method and proto parts of pp_entersub into separate functions
117# - various minor cleanups
f4a44678
SM
118# Changes after 0.57:
119# - added parens in \&foo (patch by Albert Dvornik)
120# Changes between 0.57 and 0.58:
e38ccfd9 121# - fixed '0' statements that weren't being printed
f4a44678
SM
122# - added methods for use from other programs
123# (based on patches from James Duncan and Hugo van der Sanden)
124# - added -si and -sT to control indenting (also based on a patch from Hugo)
125# - added -sv to print something else instead of '???'
126# - preliminary version of utf8 tr/// handling
3ed82cfc
GS
127# Changes after 0.58:
128# - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
d989cdac 129# - added support for Hugo's new OP_SETSTATE (like nextstate)
3ed82cfc
GS
130# Changes between 0.58 and 0.59
131# - added support for Chip's OP_METHOD_NAMED
132# - added support for Ilya's OPpTARGET_MY optimization
e38ccfd9 133# - elided arrows before '()' subscripts when possible
58cccf98 134# Changes between 0.59 and 0.60
c4a6f826 135# - support for method attributes was added
58cccf98
SM
136# - some warnings fixed
137# - separate recognition of constant subs
c4a6f826 138# - rewrote continue block handling, now recognizing for loops
58cccf98 139# - added more control of expanding control structures
c7f67cde
RH
140# Changes between 0.60 and 0.61 (mostly by Robin Houston)
141# - many bug-fixes
142# - support for pragmas and 'use'
143# - support for the little-used $[ variable
144# - support for __DATA__ sections
145# - UTF8 support
146# - BEGIN, CHECK, INIT and END blocks
147# - scoping of subroutine declarations fixed
148# - compile-time output from the input program can be suppressed, so that the
149# output is just the deparsed code. (a change to O.pm in fact)
150# - our() declarations
151# - *all* the known bugs are now listed in the BUGS section
152# - comprehensive test mechanism (TEST -deparse)
9a58b761
RGS
153# Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
154# - bug-fixes
155# - new switch -P
156# - support for command-line switches (-l, -0, etc.)
d989cdac
SM
157# Changes between 0.63 and 0.64
158# - support for //, CHECK blocks, and assertions
159# - improved handling of foreach loops and lexicals
160# - option to use Data::Dumper for constants
161# - more bug fixes
162# - discovered lots more bugs not yet fixed
0d863452
RH
163#
164# ...
165#
166# Changes between 0.72 and 0.73
167# - support new switch constructs
6e90668e
SM
168
169# Todo:
2a9e2f8a
RH
170# (See also BUGS section at the end of this file)
171#
f4a44678
SM
172# - finish tr/// changes
173# - add option for even more parens (generalize \&foo change)
90be192f 174# - left/right context
58cccf98 175# - copy comments (look at real text with $^P?)
f5aa8f4e 176# - avoid semis in one-statement blocks
9d2c6865 177# - associativity of &&=, ||=, ?:
6e90668e
SM
178# - ',' => '=>' (auto-unquote?)
179# - break long lines ("\r" as discretionary break?)
f4a44678
SM
180# - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
181# - more style options: brace style, hex vs. octal, quotes, ...
182# - print big ints as hex/octal instead of decimal (heuristic?)
e38ccfd9 183# - handle 'my $x if 0'?
6e90668e
SM
184# - version using op_next instead of op_first/sibling?
185# - avoid string copies (pass arrays, one big join?)
9d2c6865 186# - here-docs?
6e90668e 187
d989cdac 188# Current test.deparse failures
d989cdac
SM
189# comp/hints 6 - location of BEGIN blocks wrt. block openings
190# run/switchI 1 - missing -I switches entirely
191# perl -Ifoo -e 'print @INC'
192# op/caller 2 - warning mask propagates backwards before warnings::register
193# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
194# op/getpid 2 - can't assign to shared my() declaration (threads only)
195# 'my $x : shared = 5'
c4a6f826 196# op/override 7 - parens on overridden require change v-string interpretation
d989cdac
SM
197# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
198# c.f. 'BEGIN { *f = sub {0} }; f 2'
199# op/pat 774 - losing Unicode-ness of Latin1-only strings
200# 'use charnames ":short"; $x="\N{latin:a with acute}"'
201# op/recurse 12 - missing parens on recursive call makes it look like method
202# 'sub f { f($x) }'
203# op/subst 90 - inconsistent handling of utf8 under "use utf8"
204# op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
205# op/tiehandle compile - "use strict" deparsed in the wrong place
206# uni/tr_ several
207# ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
208# ext/Data/Dumper/t/dumper compile
209# ext/DB_file/several
210# ext/Encode/several
211# ext/Ernno/Errno warnings
212# ext/IO/lib/IO/t/io_sel 23
213# ext/PerlIO/t/encoding compile
214# ext/POSIX/t/posix 6
215# ext/Socket/Socket 8
216# ext/Storable/t/croak compile
217# lib/Attribute/Handlers/t/multi compile
218# lib/bignum/ several
219# lib/charnames 35
220# lib/constant 32
221# lib/English 40
222# lib/ExtUtils/t/bytes 4
223# lib/File/DosGlob compile
224# lib/Filter/Simple/t/data 1
225# lib/Math/BigInt/t/constant 1
226# lib/Net/t/config Deparse-warning
227# lib/overload compile
228# lib/Switch/ several
229# lib/Symbol 4
230# lib/Test/Simple several
231# lib/Term/Complete
232# lib/Tie/File/t/29_downcopy 5
233# lib/vars 22
f5aa8f4e 234
fb0be344 235# Object fields:
6e90668e 236#
de4fa237
FC
237# in_coderef2text:
238# True when deparsing via $deparse->coderef2text; false when deparsing the
239# main program.
240#
6e90668e
SM
241# avoid_local:
242# (local($a), local($b)) and local($a, $b) have the same internal
243# representation but the short form looks better. We notice we can
244# use a large-scale local when checking the list, but need to prevent
d989cdac 245# individual locals too. This hash holds the addresses of OPs that
6e90668e
SM
246# have already had their local-ness accounted for. The same thing
247# is done with my().
248#
249# curcv:
250# CV for current sub (or main program) being deparsed
251#
8510e997 252# curcvlex:
415d4c68
FC
253# Cached hash of lexical variables for curcv: keys are
254# names prefixed with "m" or "o" (representing my/our), and
56cd2ef8
FC
255# each value is an array with two elements indicating the cop_seq
256# of scopes in which a var of that name is valid and a third ele-
257# ment referencing the pad name.
8510e997 258#
34a48b4b
RH
259# curcop:
260# COP for statement being deparsed
261#
6e90668e
SM
262# curstash:
263# name of the current package for deparsed code
264#
265# subs_todo:
c310a5ab
FC
266# array of [cop_seq, CV, is_format?, name] for subs and formats we still
267# want to deparse. The fourth element is a pad name thingy for lexical
268# subs or a string for special blocks. For other subs, it is undef. For
269# lexical subs, CV may be undef, indicating a stub declaration.
6e90668e 270#
f5aa8f4e
SM
271# protos_todo:
272# as above, but [name, prototype] for subs that never got a GV
273#
6e90668e
SM
274# subs_done, forms_done:
275# keys are addresses of GVs for subs and formats we've already
276# deparsed (or at least put into subs_todo)
9d2c6865 277#
0ca62a8e
RH
278# subs_declared
279# keys are names of subs for which we've printed declarations.
4a1ac32e
FC
280# That means we can omit parentheses from the arguments. It also means we
281# need to put CORE:: on core functions of the same name.
0ca62a8e 282#
9f125c4a
FC
283# in_subst_repl
284# True when deparsing the replacement part of a substitution.
285#
c8ec376c
FC
286# in_refgen
287# True when deparsing the argument to \.
288#
9d2c6865 289# parens: -p
f5aa8f4e 290# linenums: -l
bd0865ec 291# unquote: -q
e38ccfd9 292# cuddle: ' ' or '\n', depending on -sC
f4a44678
SM
293# indent_size: -si
294# use_tabs: -sT
295# ex_const: -sv
9d2c6865
SM
296
297# A little explanation of how precedence contexts and associativity
298# work:
299#
300# deparse() calls each per-op subroutine with an argument $cx (short
301# for context, but not the same as the cx* in the perl core), which is
302# a number describing the op's parents in terms of precedence, whether
f5aa8f4e 303# they're inside an expression or at statement level, etc. (see
9d2c6865
SM
304# chart below). When ops with children call deparse on them, they pass
305# along their precedence. Fractional values are used to implement
e38ccfd9 306# associativity ('($x + $y) + $z' => '$x + $y + $y') and related
9d2c6865
SM
307# parentheses hacks. The major disadvantage of this scheme is that
308# it doesn't know about right sides and left sides, so say if you
309# assign a listop to a variable, it can't tell it's allowed to leave
310# the parens off the listop.
311
312# Precedences:
313# 26 [TODO] inside interpolation context ("")
314# 25 left terms and list operators (leftward)
315# 24 left ->
316# 23 nonassoc ++ --
317# 22 right **
318# 21 right ! ~ \ and unary + and -
319# 20 left =~ !~
320# 19 left * / % x
321# 18 left + - .
322# 17 left << >>
323# 16 nonassoc named unary operators
324# 15 nonassoc < > <= >= lt gt le ge
325# 14 nonassoc == != <=> eq ne cmp
326# 13 left &
327# 12 left | ^
328# 11 left &&
329# 10 left ||
330# 9 nonassoc .. ...
331# 8 right ?:
332# 7 right = += -= *= etc.
333# 6 left , =>
334# 5 nonassoc list operators (rightward)
335# 4 right not
336# 3 left and
337# 2 left or xor
338# 1 statement modifiers
d989cdac 339# 0.5 statements, but still print scopes as do { ... }
9d2c6865 340# 0 statement level
93a8ff62 341# -1 format body
9d2c6865
SM
342
343# Nonprinting characters with special meaning:
344# \cS - steal parens (see maybe_parens_unop)
345# \n - newline and indent
346# \t - increase indent
e38ccfd9 347# \b - decrease indent ('outdent')
f5aa8f4e 348# \f - flush left (no indent)
9d2c6865 349# \cK - kill following semicolon, if any
6e90668e 350
ddb55548
FC
351# Semicolon handling:
352# - Individual statements are not deparsed with trailing semicolons.
353# (If necessary, \cK is tacked on to the end.)
354# - Whatever code joins statements together or emits them (lineseq,
355# scopeop, deparse_root) is responsible for adding semicolons where
356# necessary.
357# - use statements are deparsed with trailing semicolons because they are
358# immediately concatenated with the following statement.
359# - indent() removes semicolons wherever it sees \cK.
a7fd8ef6
DM
360
361
5e8c3db2 362BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
fedf30e1 363 nextstate dbstate rv2av rv2hv helem custom ]) {
76e14ed3
SM
364 eval "sub OP_\U$_ () { " . opnumber($_) . "}"
365}}
a7fd8ef6
DM
366
367# _pessimise_walk(): recursively walk the optree of a sub,
368# possibly undoing optimisations along the way.
369
370sub _pessimise_walk {
371 my ($self, $startop) = @_;
372
373 return unless $$startop;
374 my ($op, $prevop);
375 for ($op = $startop; $$op; $prevop = $op, $op = $op->sibling) {
376 my $ppname = $op->name;
377
378 # pessimisations start here
379
380 if ($ppname eq "padrange") {
381 # remove PADRANGE:
d5524600 382 # the original optimisation either (1) changed this:
a7fd8ef6 383 # pushmark -> (various pad and list and null ops) -> the_rest
d5524600
DM
384 # or (2), for the = @_ case, changed this:
385 # pushmark -> gv[_] -> rv2av -> (pad stuff) -> the_rest
a7fd8ef6
DM
386 # into this:
387 # padrange ----------------------------------------> the_rest
388 # so we just need to convert the padrange back into a
d5524600
DM
389 # pushmark, and in case (1), set its op_next to op_sibling,
390 # which is the head of the original chain of optimised-away
391 # pad ops, or for (2), set it to sibling->first, which is
392 # the original gv[_].
a7fd8ef6
DM
393
394 $B::overlay->{$$op} = {
76e14ed3 395 type => OP_PUSHMARK,
a7fd8ef6
DM
396 name => 'pushmark',
397 private => ($op->private & OPpLVAL_INTRO),
a7fd8ef6
DM
398 };
399 }
400
401 # pessimisations end here
402
403 if (class($op) eq 'PMOP'
404 && ref($op->pmreplroot)
405 && ${$op->pmreplroot}
406 && $op->pmreplroot->isa( 'B::OP' ))
407 {
408 $self-> _pessimise_walk($op->pmreplroot);
409 }
410
411 if ($op->flags & OPf_KIDS) {
412 $self-> _pessimise_walk($op->first);
413 }
414
415 }
416}
417
418
419# _pessimise_walk_exe(): recursively walk the op_next chain of a sub,
420# possibly undoing optimisations along the way.
421
422sub _pessimise_walk_exe {
423 my ($self, $startop, $visited) = @_;
424
425 return unless $$startop;
426 return if $visited->{$$startop};
427 my ($op, $prevop);
428 for ($op = $startop; $$op; $prevop = $op, $op = $op->next) {
429 last if $visited->{$$op};
430 $visited->{$$op} = 1;
431 my $ppname = $op->name;
432 if ($ppname =~
433 /^((and|d?or)(assign)?|(map|grep)while|range|cond_expr|once)$/
434 # entertry is also a logop, but its op_other invariably points
435 # into the same chain as the main execution path, so we skip it
436 ) {
437 $self->_pessimise_walk_exe($op->other, $visited);
438 }
439 elsif ($ppname eq "subst") {
440 $self->_pessimise_walk_exe($op->pmreplstart, $visited);
441 }
442 elsif ($ppname =~ /^(enter(loop|iter))$/) {
443 # redoop and nextop will already be covered by the main block
444 # of the loop
445 $self->_pessimise_walk_exe($op->lastop, $visited);
446 }
447
448 # pessimisations start here
449 }
450}
451
e63cc694 452# Go through an optree and "remove" some optimisations by using an
a7fd8ef6
DM
453# overlay to selectively modify or un-null some ops. Deparsing in the
454# absence of those optimisations is then easier.
455#
456# Note that older optimisations are not removed, as Deparse was already
457# written to recognise them before the pessimise/overlay system was added.
458
459sub pessimise {
460 my ($self, $root, $start) = @_;
461
462 # walk tree in root-to-branch order
463 $self->_pessimise_walk($root);
464
465 my %visited;
466 # walk tree in execution order
467 $self->_pessimise_walk_exe($start, \%visited);
468}
469
470
6e90668e
SM
471sub null {
472 my $op = shift;
473 return class($op) eq "NULL";
474}
475
476sub todo {
477 my $self = shift;
c310a5ab 478 my($cv, $is_form, $name) = @_;
e31885a0 479 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
6e90668e 480 my $seq;
d989cdac
SM
481 if ($cv->OUTSIDE_SEQ) {
482 $seq = $cv->OUTSIDE_SEQ;
483 } elsif (!null($cv->START) and is_state($cv->START)) {
6e90668e
SM
484 $seq = $cv->START->cop_seq;
485 } else {
486 $seq = 0;
487 }
c310a5ab 488 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form, $name];
6e90668e
SM
489}
490
491sub next_todo {
492 my $self = shift;
493 my $ent = shift @{$self->{'subs_todo'}};
34a48b4b 494 my $cv = $ent->[1];
c310a5ab 495 if (ref $ent->[3]) { # lexical sub
d4f1bfe7
FC
496 my @text;
497
498 # At this point, we may not yet have deparsed the hints that allow
499 # lexical subroutines to be recognized. So adjust the current
500 # hints and deparse them.
501 # When lex subs cease being experimental, we should be able to
502 # remove this code.
503 {
504 local $^H = $self->{'hints'};
505 local %^H = %{ $self->{'hinthash'} || {} };
506 local ${^WARNING_BITS} = $self->{'warnings'};
507 feature->import("lexical_subs");
508 warnings->unimport("experimental::lexical_subs");
509 # Here we depend on the fact that individual features
510 # will always set the feature bundle to ‘custom’
511 # (== $feature::hint_mask). If we had another specific bundle
512 # enabled previously, normalise it.
513 if (($self->{'hints'} & $feature::hint_mask)
514 != $feature::hint_mask)
515 {
516 if ($self->{'hinthash'}) {
517 delete $self->{'hinthash'}{$_}
518 for grep /^feature_/, keys %{$self->{'hinthash'}};
519 }
520 else { $self->{'hinthash'} = {} }
521 $self->{'hinthash'}
522 = _features_from_bundle(@$self{'hints','hinthash'});
523 }
524 push @text, $self->declare_hinthash($self->{'hinthash'}, \%^H,
525 $self->{indent_size}, $^H);
526 push @text, $self->declare_warnings($self->{'warnings'},
527 ${^WARNING_BITS})
528 unless ($self->{'warnings'} // 'u')
529 eq (${^WARNING_BITS } // 'u');
530 $self->{'warnings'} = ${^WARNING_BITS};
531 $self->{'hints'} = $^H;
532 $self->{'hinthash'} = {%^H};
533 }
534
535 # Now emit the sub itself.
536 my $padname = $ent->[3];
537 my $flags = $padname->FLAGS;
538 push @text,
539 !$cv || $ent->[0] <= $padname->COP_SEQ_RANGE_LOW
540 ? $self->keyword($flags & SVpad_OUR
541 ? "our"
542 : $flags & SVpad_STATE
543 ? "state"
544 : "my") . " "
545 : "";
546 # XXX We would do $self->keyword("sub"), but ‘my CORE::sub’
547 # doesn’t work and ‘my sub’ ignores a &sub in scope. I.e.,
548 # we have a core bug here.
549 push @text, "sub " . substr $padname->PVX, 1;
550 if ($cv) {
551 # my sub foo { }
552 push @text, " " . $self->deparse_sub($cv);
553 $text[-1] =~ s/ ;$/;/;
554 }
555 else {
556 # my sub foo;
557 push @text, ";\n";
558 }
559 return join "", @text;
560 }
34a48b4b 561 my $gv = $cv->GV;
c310a5ab 562 my $name = $ent->[3] // $self->gv_name($gv);
6e90668e 563 if ($ent->[2]) {
7741ceed 564 return $self->keyword("format") . " $name =\n"
e31885a0 565 . $self->deparse_format($ent->[1]). "\n";
6e90668e 566 } else {
d98ae4a6 567 my $use_dec;
34a48b4b 568 if ($name eq "BEGIN") {
d98ae4a6 569 $use_dec = $self->begin_is_use($cv);
d989cdac 570 if (defined ($use_dec) and $self->{'expand'} < 5) {
0e7fe0f0 571 return () if 0 == length($use_dec);
7741ceed 572 $use_dec =~ s/^(use|no)\b/$self->keyword($1)/e;
0e7fe0f0 573 }
34a48b4b 574 }
a0035eb8
RH
575 my $l = '';
576 if ($self->{'linenums'}) {
577 my $line = $gv->LINE;
578 my $file = $gv->FILE;
579 $l = "\n\f#line $line \"$file\"\n";
580 }
127212b2 581 my $p = '';
d49c3562 582 my $stash;
127212b2 583 if (class($cv->STASH) ne "SPECIAL") {
d49c3562 584 $stash = $cv->STASH->NAME;
127212b2 585 if ($stash ne $self->{'curstash'}) {
7741ceed 586 $p = $self->keyword("package") . " $stash;\n";
127212b2
DM
587 $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
588 $self->{'curstash'} = $stash;
589 }
127212b2 590 }
d98ae4a6
FC
591 if ($use_dec) {
592 return "$p$l$use_dec";
593 }
d49c3562
FC
594 if ( $name !~ /::/ and $self->lex_in_scope("&$name")
595 || $self->lex_in_scope("&$name", 1) )
596 {
597 $name = "$self->{'curstash'}::$name";
598 } elsif (defined $stash) {
599 $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
600 }
f518ad75 601 my $ret = "${p}${l}" . $self->keyword("sub") . " $name "
7741ceed 602 . $self->deparse_sub($cv);
f518ad75
FC
603 $self->{'subs_declared'}{$name} = 1;
604 return $ret;
34a48b4b
RH
605 }
606}
607
608# Return a "use" declaration for this BEGIN block, if appropriate
609sub begin_is_use {
610 my ($self, $cv) = @_;
611 my $root = $cv->ROOT;
80dc0729 612 local @$self{qw'curcv curcvlex'} = ($cv);
a7fd8ef6
DM
613 local $B::overlay = {};
614 $self->pessimise($root, $cv->START);
34a48b4b
RH
615#require B::Debug;
616#B::walkoptree($cv->ROOT, "debug");
617 my $lineseq = $root->first;
618 return if $lineseq->name ne "lineseq";
619
620 my $req_op = $lineseq->first->sibling;
621 return if $req_op->name ne "require";
622
623 my $module;
624 if ($req_op->first->private & OPpCONST_BARE) {
625 # Actually it should always be a bareword
626 $module = $self->const_sv($req_op->first)->PV;
627 $module =~ s[/][::]g;
628 $module =~ s/.pm$//;
629 }
630 else {
d989cdac 631 $module = $self->const($self->const_sv($req_op->first), 6);
34a48b4b
RH
632 }
633
634 my $version;
635 my $version_op = $req_op->sibling;
636 return if class($version_op) eq "NULL";
637 if ($version_op->name eq "lineseq") {
638 # We have a version parameter; skip nextstate & pushmark
639 my $constop = $version_op->first->next->next;
640
641 return unless $self->const_sv($constop)->PV eq $module;
642 $constop = $constop->sibling;
a58644de 643 $version = $self->const_sv($constop);
d989cdac
SM
644 if (class($version) eq "IV") {
645 $version = $version->int_value;
646 } elsif (class($version) eq "NV") {
647 $version = $version->NV;
648 } elsif (class($version) ne "PVMG") {
649 # Includes PVIV and PVNV
a58644de
RGS
650 $version = $version->PV;
651 } else {
652 # version specified as a v-string
653 $version = 'v'.join '.', map ord, split //, $version->PV;
654 }
34a48b4b
RH
655 $constop = $constop->sibling;
656 return if $constop->name ne "method_named";
b46e009d 657 return if $self->meth_sv($constop)->PV ne "VERSION";
34a48b4b
RH
658 }
659
660 $lineseq = $version_op->sibling;
661 return if $lineseq->name ne "lineseq";
662 my $entersub = $lineseq->first->sibling;
663 if ($entersub->name eq "stub") {
664 return "use $module $version ();\n" if defined $version;
665 return "use $module ();\n";
666 }
667 return if $entersub->name ne "entersub";
668
669 # See if there are import arguments
670 my $args = '';
671
6ec152c3
RH
672 my $svop = $entersub->first->sibling; # Skip over pushmark
673 return unless $self->const_sv($svop)->PV eq $module;
34a48b4b
RH
674
675 # Pull out the arguments
7d6c333c 676 for ($svop=$svop->sibling; index($svop->name, "method_") != 0;
6ec152c3 677 $svop = $svop->sibling) {
34a48b4b 678 $args .= ", " if length($args);
6ec152c3 679 $args .= $self->deparse($svop, 6);
34a48b4b
RH
680 }
681
682 my $use = 'use';
6ec152c3 683 my $method_named = $svop;
34a48b4b 684 return if $method_named->name ne "method_named";
b46e009d 685 my $method_name = $self->meth_sv($method_named)->PV;
34a48b4b
RH
686
687 if ($method_name eq "unimport") {
688 $use = 'no';
689 }
690
691 # Certain pragmas are dealt with using hint bits,
692 # so we ignore them here
693 if ($module eq 'strict' || $module eq 'integer'
0ced6c29
RGS
694 || $module eq 'bytes' || $module eq 'warnings'
695 || $module eq 'feature') {
34a48b4b
RH
696 return "";
697 }
698
699 if (defined $version && length $args) {
700 return "$use $module $version ($args);\n";
701 } elsif (defined $version) {
702 return "$use $module $version;\n";
703 } elsif (length $args) {
704 return "$use $module ($args);\n";
705 } else {
706 return "$use $module;\n";
6e90668e
SM
707 }
708}
709
6e90668e 710sub stash_subs {
894e98ac 711 my ($self, $pack, $seen) = @_;
34a48b4b
RH
712 my (@ret, $stash);
713 if (!defined $pack) {
714 $pack = '';
715 $stash = \%::;
f5aa8f4e 716 }
34a48b4b
RH
717 else {
718 $pack =~ s/(::)?$/::/;
719 no strict 'refs';
d1dc589d 720 $stash = \%{"main::$pack"};
34a48b4b 721 }
894e98ac
FC
722 return
723 if ($seen ||= {})->{
724 $INC{"overload.pm"} ? overload::StrVal($stash) : $stash
725 }++;
34a48b4b
RH
726 my %stash = svref_2object($stash)->ARRAY;
727 while (my ($key, $val) = each %stash) {
de001ba0
FC
728 my $flags = $val->FLAGS;
729 if ($flags & SVf_ROK) {
67359f08
FC
730 # A reference. Dump this if it is a reference to a CV.
731 # But skip proxy constant subroutines, as some form of perl-
732 # space visible code must have created them, be it a use
733 # statement, or some direct symbol-table manipulation code that
734 # we will Deparse.
735 if (class(my $cv = $val->RV) eq "CV") {
736 $self->todo($cv, 0);
737 }
de001ba0 738 } elsif ($flags & (SVf_POK|SVf_IOK)) {
a0035eb8
RH
739 # Just a prototype. As an ugly but fairly effective way
740 # to find out if it belongs here is to see if the AUTOLOAD
741 # (if any) for the stash was defined in one of our files.
742 my $A = $stash{"AUTOLOAD"};
743 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
744 && class($A->CV) eq "CV") {
745 my $AF = $A->FILE;
746 next unless $AF eq $0 || exists $self->{'files'}{$AF};
747 }
de001ba0
FC
748 push @{$self->{'protos_todo'}},
749 [$pack . $key, $flags & SVf_POK ? $val->PV: undef];
750 } elsif (class($val) eq "GV") {
34a48b4b 751 if (class(my $cv = $val->CV) ne "SPECIAL") {
f5aa8f4e 752 next if $self->{'subs_done'}{$$val}++;
e31885a0 753 next if $$val != ${$cv->GV}; # Ignore imposters
8510e997 754 $self->todo($cv, 0);
f5aa8f4e 755 }
e31885a0 756 if (class(my $cv = $val->FORM) ne "SPECIAL") {
f5aa8f4e 757 next if $self->{'forms_done'}{$$val}++;
e31885a0
RH
758 next if $$val != ${$cv->GV}; # Ignore imposters
759 $self->todo($cv, 1);
f5aa8f4e 760 }
34a48b4b 761 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
74cd21ba 762 $self->stash_subs($pack . $key, $seen);
34a48b4b 763 }
6e90668e
SM
764 }
765 }
766}
a798dbf2 767
f5aa8f4e
SM
768sub print_protos {
769 my $self = shift;
770 my $ar;
771 my @ret;
772 foreach $ar (@{$self->{'protos_todo'}}) {
773 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
774 push @ret, "sub " . $ar->[0] . "$proto;\n";
775 }
776 delete $self->{'protos_todo'};
777 return @ret;
778}
779
9d2c6865
SM
780sub style_opts {
781 my $self = shift;
782 my $opts = shift;
783 my $opt;
784 while (length($opt = substr($opts, 0, 1))) {
785 if ($opt eq "C") {
786 $self->{'cuddle'} = " ";
f4a44678
SM
787 $opts = substr($opts, 1);
788 } elsif ($opt eq "i") {
789 $opts =~ s/^i(\d+)//;
790 $self->{'indent_size'} = $1;
791 } elsif ($opt eq "T") {
792 $self->{'use_tabs'} = 1;
793 $opts = substr($opts, 1);
794 } elsif ($opt eq "v") {
795 $opts =~ s/^v([^.]*)(.|$)//;
796 $self->{'ex_const'} = $1;
9d2c6865 797 }
9d2c6865
SM
798 }
799}
800
f4a44678
SM
801sub new {
802 my $class = shift;
803 my $self = bless {}, $class;
f4a44678 804 $self->{'cuddle'} = "\n";
d989cdac
SM
805 $self->{'curcop'} = undef;
806 $self->{'curstash'} = "main";
807 $self->{'ex_const'} = "'???'";
793e2a70 808 $self->{'expand'} = 0;
d989cdac
SM
809 $self->{'files'} = {};
810 $self->{'indent_size'} = 4;
793e2a70
RH
811 $self->{'linenums'} = 0;
812 $self->{'parens'} = 0;
d989cdac
SM
813 $self->{'subs_todo'} = [];
814 $self->{'unquote'} = 0;
815 $self->{'use_dumper'} = 0;
816 $self->{'use_tabs'} = 0;
08c6f5ec 817
bc6b2ef6 818 $self->{'ambient_arybase'} = 0;
e31885a0 819 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
a0405c92 820 $self->{'ambient_hints'} = 0;
0ced6c29 821 $self->{'ambient_hinthash'} = undef;
08c6f5ec
RH
822 $self->init();
823
f4a44678 824 while (my $arg = shift @_) {
d989cdac
SM
825 if ($arg eq "-d") {
826 $self->{'use_dumper'} = 1;
827 require Data::Dumper;
828 } elsif ($arg =~ /^-f(.*)/) {
34a48b4b 829 $self->{'files'}{$1} = 1;
d989cdac
SM
830 } elsif ($arg eq "-l") {
831 $self->{'linenums'} = 1;
f4a44678
SM
832 } elsif ($arg eq "-p") {
833 $self->{'parens'} = 1;
acaaef34
RGS
834 } elsif ($arg eq "-P") {
835 $self->{'noproto'} = 1;
f4a44678
SM
836 } elsif ($arg eq "-q") {
837 $self->{'unquote'} = 1;
838 } elsif (substr($arg, 0, 2) eq "-s") {
839 $self->style_opts(substr $arg, 2);
58cccf98
SM
840 } elsif ($arg =~ /^-x(\d)$/) {
841 $self->{'expand'} = $1;
f4a44678
SM
842 }
843 }
844 return $self;
845}
846
810aef70
RH
847{
848 # Mask out the bits that L<warnings::register> uses
849 my $WARN_MASK;
850 BEGIN {
851 $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
852 }
853 sub WARN_MASK () {
854 return $WARN_MASK;
855 }
34a48b4b
RH
856}
857
08c6f5ec
RH
858# Initialise the contextual information, either from
859# defaults provided with the ambient_pragmas method,
860# or from perl's own defaults otherwise.
861sub init {
862 my $self = shift;
863
bc6b2ef6 864 $self->{'arybase'} = $self->{'ambient_arybase'};
e31885a0
RH
865 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
866 ? $self->{'ambient_warnings'} & WARN_MASK
867 : undef;
d5ec2987 868 $self->{'hints'} = $self->{'ambient_hints'};
e412117e 869 $self->{'hints'} &= 0xFF if $] < 5.009;
0ced6c29 870 $self->{'hinthash'} = $self->{'ambient_hinthash'};
217aba5d
RH
871
872 # also a convenient place to clear out subs_declared
873 delete $self->{'subs_declared'};
08c6f5ec
RH
874}
875
a798dbf2 876sub compile {
6e90668e 877 my(@args) = @_;
d989cdac 878 return sub {
f4a44678 879 my $self = B::Deparse->new(@args);
d2bc402e
RGS
880 # First deparse command-line args
881 if (defined $^I) { # deparse -i
51a5edaf 882 print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
d2bc402e
RGS
883 }
884 if ($^W) { # deparse -w
885 print qq(BEGIN { \$^W = $^W; }\n);
886 }
887 if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
51a5edaf
RGS
888 my $fs = perlstring($/) || 'undef';
889 my $bs = perlstring($O::savebackslash) || 'undef';
d2bc402e
RGS
890 print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
891 }
34a48b4b 892 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
676456c2
AG
893 my @UNITCHECKs = B::unitcheck_av->isa("B::AV")
894 ? B::unitcheck_av->ARRAY
895 : ();
ece599bd 896 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
34a48b4b
RH
897 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
898 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
c310a5ab
FC
899 my @names = qw(BEGIN UNITCHECK CHECK INIT END);
900 my @blocks = \(@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs);
901 while (@names) {
902 my ($name, $blocks) = (shift @names, shift @blocks);
903 for my $block (@$blocks) {
904 $self->todo($block, 0, $name);
905 }
34a48b4b
RH
906 }
907 $self->stash_subs();
d989cdac
SM
908 local($SIG{"__DIE__"}) =
909 sub {
910 if ($self->{'curcop'}) {
911 my $cop = $self->{'curcop'};
912 my($line, $file) = ($cop->line, $cop->file);
913 print STDERR "While deparsing $file near line $line,\n";
914 }
915 };
6e90668e 916 $self->{'curcv'} = main_cv;
8510e997 917 $self->{'curcvlex'} = undef;
f5aa8f4e 918 print $self->print_protos;
6e90668e 919 @{$self->{'subs_todo'}} =
f4a44678 920 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
a7fd8ef6
DM
921 my $root = main_root;
922 local $B::overlay = {};
923 unless (null $root) {
d4f1bfe7 924 $self->pad_subs($self->{'curcv'});
6436970c
FC
925 # Check for a stub-followed-by-ex-cop, resulting from a program
926 # consisting solely of sub declarations. For backward-compati-
927 # bility (and sane output) we don’t want to emit the stub.
928 # leave
929 # enter
930 # stub
931 # ex-nextstate (or ex-dbstate)
932 my $kid;
933 if ( $root->name eq 'leave'
934 and ($kid = $root->first)->name eq 'enter'
935 and !null($kid = $kid->sibling) and $kid->name eq 'stub'
936 and !null($kid = $kid->sibling) and $kid->name eq 'null'
937 and class($kid) eq 'COP' and null $kid->sibling )
938 {
939 # ignore
940 } else {
941 $self->pessimise($root, main_start);
942 print $self->indent($self->deparse_root($root)), "\n";
943 }
a7fd8ef6 944 }
6e90668e
SM
945 my @text;
946 while (scalar(@{$self->{'subs_todo'}})) {
947 push @text, $self->next_todo;
948 }
6f611a1a 949 print $self->indent(join("", @text)), "\n" if @text;
e31885a0
RH
950
951 # Print __DATA__ section, if necessary
952 no strict 'refs';
96c57f7e
RGS
953 my $laststash = defined $self->{'curcop'}
954 ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
955 if (defined *{$laststash."::DATA"}{IO}) {
7741ceed 956 print $self->keyword("package") . " $laststash;\n"
127212b2 957 unless $laststash eq $self->{'curstash'};
7741ceed 958 print $self->keyword("__DATA__") . "\n";
96c57f7e 959 print readline(*{$laststash."::DATA"});
e31885a0 960 }
a798dbf2 961 }
a798dbf2
MB
962}
963
f4a44678
SM
964sub coderef2text {
965 my $self = shift;
966 my $sub = shift;
0853f172 967 croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
08c6f5ec
RH
968
969 $self->init();
de4fa237 970 local $self->{in_coderef2text} = 1;
f4a44678
SM
971 return $self->indent($self->deparse_sub(svref_2object($sub)));
972}
973
415d4c68 974my %strict_bits = do {
d1718a7c 975 local $^H;
415d4c68
FC
976 map +($_ => strict::bits($_)), qw/refs subs vars/
977};
978
08c6f5ec
RH
979sub ambient_pragmas {
980 my $self = shift;
bc6b2ef6 981 my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
08c6f5ec
RH
982
983 while (@_ > 1) {
984 my $name = shift();
985 my $val = shift();
986
987 if ($name eq 'strict') {
988 require strict;
989
990 if ($val eq 'none') {
415d4c68 991 $hint_bits &= $strict_bits{$_} for qw/refs subs vars/;
08c6f5ec
RH
992 next();
993 }
994
995 my @names;
996 if ($val eq "all") {
997 @names = qw/refs subs vars/;
998 }
999 elsif (ref $val) {
1000 @names = @$val;
1001 }
1002 else {
a0405c92 1003 @names = split' ', $val;
08c6f5ec 1004 }
415d4c68 1005 $hint_bits |= $strict_bits{$_} for @names;
08c6f5ec
RH
1006 }
1007
bc6b2ef6
Z
1008 elsif ($name eq '$[') {
1009 if (OPpCONST_ARYBASE) {
1010 $arybase = $val;
1011 } else {
1012 croak "\$[ can't be non-zero on this perl" unless $val == 0;
1013 }
1014 }
1015
a0405c92
RH
1016 elsif ($name eq 'integer'
1017 || $name eq 'bytes'
1018 || $name eq 'utf8') {
1019 require "$name.pm";
08c6f5ec 1020 if ($val) {
a0405c92
RH
1021 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
1022 }
1023 else {
1024 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
1025 }
1026 }
1027
1028 elsif ($name eq 're') {
1029 require re;
1030 if ($val eq 'none') {
2570cdf1 1031 $hint_bits &= ~re::bits(qw/taint eval/);
a0405c92
RH
1032 next();
1033 }
1034
1035 my @names;
1036 if ($val eq 'all') {
2570cdf1 1037 @names = qw/taint eval/;
a0405c92
RH
1038 }
1039 elsif (ref $val) {
1040 @names = @$val;
08c6f5ec
RH
1041 }
1042 else {
a0405c92 1043 @names = split' ',$val;
08c6f5ec 1044 }
a0405c92 1045 $hint_bits |= re::bits(@names);
08c6f5ec
RH
1046 }
1047
1048 elsif ($name eq 'warnings') {
08c6f5ec 1049 if ($val eq 'none') {
810aef70 1050 $warning_bits = $warnings::NONE;
08c6f5ec
RH
1051 next();
1052 }
1053
1054 my @names;
1055 if (ref $val) {
1056 @names = @$val;
1057 }
1058 else {
1059 @names = split/\s+/, $val;
1060 }
1061
810aef70 1062 $warning_bits = $warnings::NONE if !defined ($warning_bits);
08c6f5ec
RH
1063 $warning_bits |= warnings::bits(@names);
1064 }
1065
1066 elsif ($name eq 'warning_bits') {
1067 $warning_bits = $val;
1068 }
1069
1070 elsif ($name eq 'hint_bits') {
1071 $hint_bits = $val;
1072 }
1073
0ced6c29
RGS
1074 elsif ($name eq '%^H') {
1075 $hinthash = $val;
1076 }
1077
08c6f5ec
RH
1078 else {
1079 croak "Unknown pragma type: $name";
1080 }
1081 }
1082 if (@_) {
1083 croak "The ambient_pragmas method expects an even number of args";
1084 }
1085
bc6b2ef6 1086 $self->{'ambient_arybase'} = $arybase;
08c6f5ec 1087 $self->{'ambient_warnings'} = $warning_bits;
a0405c92 1088 $self->{'ambient_hints'} = $hint_bits;
0ced6c29 1089 $self->{'ambient_hinthash'} = $hinthash;
08c6f5ec
RH
1090}
1091
d989cdac 1092# This method is the inner loop, so try to keep it simple
6e90668e
SM
1093sub deparse {
1094 my $self = shift;
d989cdac 1095 my($op, $cx) = @_;
34a48b4b
RH
1096
1097 Carp::confess("Null op in deparse") if !defined($op)
1098 || class($op) eq "NULL";
3f872cb9 1099 my $meth = "pp_" . $op->name;
9d2c6865 1100 return $self->$meth($op, $cx);
a798dbf2
MB
1101}
1102
6e90668e 1103sub indent {
f4a44678 1104 my $self = shift;
6e90668e 1105 my $txt = shift;
5e617af5
FC
1106 # \cK also swallows a preceding line break when followed by a
1107 # semicolon.
1108 $txt =~ s/\n\cK;//g;
6e90668e
SM
1109 my @lines = split(/\n/, $txt);
1110 my $leader = "";
f4a44678 1111 my $level = 0;
6e90668e
SM
1112 my $line;
1113 for $line (@lines) {
f4a44678
SM
1114 my $cmd = substr($line, 0, 1);
1115 if ($cmd eq "\t" or $cmd eq "\b") {
1116 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
1117 if ($self->{'use_tabs'}) {
1118 $leader = "\t" x ($level / 8) . " " x ($level % 8);
1119 } else {
1120 $leader = " " x $level;
1121 }
6e90668e
SM
1122 $line = substr($line, 1);
1123 }
f2734596 1124 if (index($line, "\f") > 0) {
1125 $line =~ s/\f/\n/;
1126 }
f5aa8f4e
SM
1127 if (substr($line, 0, 1) eq "\f") {
1128 $line = substr($line, 1); # no indent
1129 } else {
1130 $line = $leader . $line;
1131 }
9d2c6865 1132 $line =~ s/\cK;?//g;
6e90668e
SM
1133 }
1134 return join("\n", @lines);
1135}
1136
d4f1bfe7
FC
1137sub pad_subs {
1138 my ($self, $cv) = @_;
1139 my $padlist = $cv->PADLIST;
1140 my @names = $padlist->ARRAYelt(0)->ARRAY;
1141 my @values = $padlist->ARRAYelt(1)->ARRAY;
1142 my @todo;
1143 for my $ix (0.. $#names) { for $_ ($names[$ix]) {
1144 next if class($_) eq "SPECIAL";
1145 my $name = $_->PVX;
679f2252 1146 if (defined $name && $name =~ /^&./) {
d4f1bfe7
FC
1147 my $low = $_->COP_SEQ_RANGE_LOW;
1148 my $flags = $_->FLAGS;
1149 if ($flags & SVpad_OUR) {
1150 push @todo, [$low, undef, 0, $_];
1151 # [seq, no cv, not format, padname]
1152 next;
1153 }
1154 my $protocv = $flags & SVpad_STATE
1155 ? $values[$ix]
97d78f94 1156 : $_->PROTOCV;
d4f1bfe7
FC
1157 my $outseq = $protocv->OUTSIDE_SEQ;
1158 if ($outseq <= $low) {
1159 # defined before its name is visible, so it’s gotta be
1160 # declared and defined at once: my sub foo { ... }
1161 push @todo, [$low, $protocv, 0, $_];
1162 }
1163 else {
1164 # declared and defined separately: my sub f; sub f { ... }
1165 push @todo, [$low, undef, 0, $_],
1166 [$outseq, $protocv, 0, $_];
1167 }
1168 }
1169 }}
1170 @{$self->{'subs_todo'}} =
1171 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo
1172}
1173
6e90668e
SM
1174sub deparse_sub {
1175 my $self = shift;
1176 my $cv = shift;
1177 my $proto = "";
ce4e655d 1178Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
34a48b4b
RH
1179Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
1180 local $self->{'curcop'} = $self->{'curcop'};
6e90668e
SM
1181 if ($cv->FLAGS & SVf_POK) {
1182 $proto = "(". $cv->PV . ") ";
1183 }
aa381260 1184 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
6aaf4108
SC
1185 $proto .= ": ";
1186 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
aa381260 1187 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
6aaf4108
SC
1188 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
1189 }
1190
6e90668e 1191 local($self->{'curcv'}) = $cv;
8510e997 1192 local($self->{'curcvlex'});
0ced6c29
RGS
1193 local(@$self{qw'curstash warnings hints hinthash'})
1194 = @$self{qw'curstash warnings hints hinthash'};
ce4e655d 1195 my $body;
a7fd8ef6
DM
1196 my $root = $cv->ROOT;
1197 local $B::overlay = {};
1198 if (not null $root) {
d4f1bfe7 1199 $self->pad_subs($cv);
a7fd8ef6
DM
1200 $self->pessimise($root, $cv->START);
1201 my $lineseq = $root->first;
ce4e655d
RH
1202 if ($lineseq->name eq "lineseq") {
1203 my @ops;
1204 for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
1205 push @ops, $o;
1206 }
93a8ff62 1207 $body = $self->lineseq(undef, 0, @ops).";";
ce4e655d
RH
1208 my $scope_en = $self->find_scope_en($lineseq);
1209 if (defined $scope_en) {
1210 my $subs = join"", $self->seq_subs($scope_en);
1211 $body .= ";\n$subs" if length($subs);
1212 }
1213 }
1214 else {
a7fd8ef6 1215 $body = $self->deparse($root->first, 0);
ce4e655d 1216 }
de3f1649 1217 }
ce4e655d
RH
1218 else {
1219 my $sv = $cv->const_sv;
1220 if ($$sv) {
1221 # uh-oh. inlinable sub... format it differently
d989cdac 1222 return $proto . "{ " . $self->const($sv, 0) . " }\n";
ce4e655d
RH
1223 } else { # XSUB? (or just a declaration)
1224 return "$proto;\n";
1225 }
6e90668e 1226 }
ce4e655d 1227 return $proto ."{\n\t$body\n\b}" ."\n";
6e90668e
SM
1228}
1229
1230sub deparse_format {
1231 my $self = shift;
1232 my $form = shift;
1233 my @text;
1234 local($self->{'curcv'}) = $form;
8510e997 1235 local($self->{'curcvlex'});
67fc2416 1236 local($self->{'in_format'}) = 1;
0ced6c29
RGS
1237 local(@$self{qw'curstash warnings hints hinthash'})
1238 = @$self{qw'curstash warnings hints hinthash'};
6e90668e 1239 my $op = $form->ROOT;
a7fd8ef6
DM
1240 local $B::overlay = {};
1241 $self->pessimise($op, $form->START);
6e90668e 1242 my $kid;
fb725297
RGS
1243 return "\f." if $op->first->name eq 'stub'
1244 || $op->first->name eq 'nextstate';
6e90668e
SM
1245 $op = $op->first->first; # skip leavewrite, lineseq
1246 while (not null $op) {
1247 $op = $op->sibling; # skip nextstate
1248 my @exprs;
1249 $kid = $op->first->sibling; # skip pushmark
a5b0cd91 1250 push @text, "\f".$self->const_sv($kid)->PV;
6e90668e
SM
1251 $kid = $kid->sibling;
1252 for (; not null $kid; $kid = $kid->sibling) {
93a8ff62 1253 push @exprs, $self->deparse($kid, -1);
31c26a0a 1254 $exprs[-1] =~ s/;\z//;
6e90668e 1255 }
a5b0cd91 1256 push @text, "\f".join(", ", @exprs)."\n" if @exprs;
6e90668e
SM
1257 $op = $op->sibling;
1258 }
a5b0cd91 1259 return join("", @text) . "\f.";
6e90668e
SM
1260}
1261
6e90668e 1262sub is_scope {
a798dbf2 1263 my $op = shift;
3f872cb9
GS
1264 return $op->name eq "leave" || $op->name eq "scope"
1265 || $op->name eq "lineseq"
d989cdac 1266 || ($op->name eq "null" && class($op) eq "UNOP"
3f872cb9 1267 && (is_scope($op->first) || $op->first->name eq "enter"));
6e90668e
SM
1268}
1269
1270sub is_state {
3f872cb9
GS
1271 my $name = $_[0]->name;
1272 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
6e90668e
SM
1273}
1274
e38ccfd9 1275sub is_miniwhile { # check for one-line loop ('foo() while $y--')
6e90668e 1276 my $op = shift;
d989cdac 1277 return (!null($op) and null($op->sibling)
3f872cb9
GS
1278 and $op->name eq "null" and class($op) eq "UNOP"
1279 and (($op->first->name =~ /^(and|or)$/
1280 and $op->first->first->sibling->name eq "lineseq")
1281 or ($op->first->name eq "lineseq"
6e90668e 1282 and not null $op->first->first->sibling
3f872cb9 1283 and $op->first->first->sibling->name eq "unstack")
6e90668e
SM
1284 ));
1285}
1286
d989cdac
SM
1287# Check if the op and its sibling are the initialization and the rest of a
1288# for (..;..;..) { ... } loop
1289sub is_for_loop {
1290 my $op = shift;
1291 # This OP might be almost anything, though it won't be a
1292 # nextstate. (It's the initialization, so in the canonical case it
eae48c89
Z
1293 # will be an sassign.) The sibling is (old style) a lineseq whose
1294 # first child is a nextstate and whose second is a leaveloop, or
1295 # (new style) an unstack whose sibling is a leaveloop.
d989cdac 1296 my $lseq = $op->sibling;
eae48c89
Z
1297 return 0 unless !is_state($op) and !null($lseq);
1298 if ($lseq->name eq "lineseq") {
d989cdac
SM
1299 if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
1300 && (my $sib = $lseq->first->sibling)) {
1301 return (!null($sib) && $sib->name eq "leaveloop");
1302 }
eae48c89
Z
1303 } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) {
1304 my $sib = $lseq->sibling;
1305 return $sib && !null($sib) && $sib->name eq "leaveloop";
d989cdac
SM
1306 }
1307 return 0;
1308}
1309
6e90668e
SM
1310sub is_scalar {
1311 my $op = shift;
3f872cb9
GS
1312 return ($op->name eq "rv2sv" or
1313 $op->name eq "padsv" or
1314 $op->name eq "gv" or # only in array/hash constructs
bd0865ec 1315 $op->flags & OPf_KIDS && !null($op->first)
3f872cb9 1316 && $op->first->name eq "gvsv");
6e90668e
SM
1317}
1318
9d2c6865
SM
1319sub maybe_parens {
1320 my $self = shift;
1321 my($text, $cx, $prec) = @_;
1322 if ($prec < $cx # unary ops nest just fine
1323 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
1324 or $self->{'parens'})
1325 {
1326 $text = "($text)";
1327 # In a unop, let parent reuse our parens; see maybe_parens_unop
1328 $text = "\cS" . $text if $cx == 16;
1329 return $text;
1330 } else {
1331 return $text;
1332 }
1333}
1334
e38ccfd9 1335# same as above, but get around the 'if it looks like a function' rule
9d2c6865
SM
1336sub maybe_parens_unop {
1337 my $self = shift;
1338 my($name, $kid, $cx) = @_;
1339 if ($cx > 16 or $self->{'parens'}) {
a0035eb8
RH
1340 $kid = $self->deparse($kid, 1);
1341 if ($name eq "umask" && $kid =~ /^\d+$/) {
1342 $kid = sprintf("%#o", $kid);
1343 }
4a1ac32e 1344 return $self->keyword($name) . "($kid)";
9d2c6865
SM
1345 } else {
1346 $kid = $self->deparse($kid, 16);
a0035eb8
RH
1347 if ($name eq "umask" && $kid =~ /^\d+$/) {
1348 $kid = sprintf("%#o", $kid);
1349 }
4a1ac32e 1350 $name = $self->keyword($name);
9d2c6865
SM
1351 if (substr($kid, 0, 1) eq "\cS") {
1352 # use kid's parens
1353 return $name . substr($kid, 1);
1354 } elsif (substr($kid, 0, 1) eq "(") {
1355 # avoid looks-like-a-function trap with extra parens
e38ccfd9 1356 # ('+' can lead to ambiguities)
9d2c6865
SM
1357 return "$name(" . $kid . ")";
1358 } else {
1359 return "$name $kid";
1360 }
1361 }
1362}
1363
1364sub maybe_parens_func {
1365 my $self = shift;
1366 my($func, $text, $cx, $prec) = @_;
1367 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
1368 return "$func($text)";
1369 } else {
1370 return "$func $text";
1371 }
1372}
1373
56cd2ef8
FC
1374sub find_our_type {
1375 my ($self, $name) = @_;
1376 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
5afbd733 1377 my $seq = $self->{'curcop'} ? $self->{'curcop'}->cop_seq : 0;
56cd2ef8
FC
1378 for my $a (@{$self->{'curcvlex'}{"o$name"}}) {
1379 my ($st, undef, $padname) = @$a;
5afbd733 1380 if ($st >= $seq && $padname->FLAGS & SVpad_TYPED) {
56cd2ef8
FC
1381 return $padname->SvSTASH->NAME;
1382 }
1383 }
1384 return '';
1385}
1386
6e90668e
SM
1387sub maybe_local {
1388 my $self = shift;
9d2c6865 1389 my($op, $cx, $text) = @_;
c8ec376c 1390 my $name = $op->name;
9187b6e4
FC
1391 my $our_intro = ($name =~ /^(?:(?:gv|rv2)[ash]v|split|refassign
1392 |lv(?:av)?ref)$/x)
de183bbb
FC
1393 ? OPpOUR_INTRO
1394 : 0;
1395 my $lval_intro = $name eq 'split' ? 0 : OPpLVAL_INTRO;
c8ec376c
FC
1396 # The @a in \(@a) isn't in ref context, but only when the
1397 # parens are there.
1398 my $need_parens = $self->{'in_refgen'} && $name =~ /[ah]v\z/
1399 && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
de183bbb 1400 if ((my $priv = $op->private) & ($lval_intro|$our_intro)) {
f3515641 1401 my @our_local;
de183bbb 1402 push @our_local, "local" if $priv & $lval_intro;
f3515641 1403 push @our_local, "our" if $priv & $our_intro;
3188a821 1404 my $our_local = join " ", map $self->keyword($_), @our_local;
f3515641 1405 if( $our_local[-1] eq 'our' ) {
640d5d41
FC
1406 if ( $text !~ /^\W(\w+::)*\w+\z/
1407 and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
1408 ) {
1409 die "Unexpected our($text)\n";
1410 }
d989cdac 1411 $text =~ s/(\w+::)+//;
56cd2ef8
FC
1412
1413 if (my $type = $self->find_our_type($text)) {
1414 $our_local .= ' ' . $type;
1415 }
8e3542b6 1416 }
c8ec376c
FC
1417 return $need_parens ? "($text)" : $text
1418 if $self->{'avoid_local'}{$$op};
1419 if ($need_parens) {
1420 return "$our_local($text)";
1421 } elsif (want_scalar($op)) {
ce4e655d 1422 return "$our_local $text";
e8d3f51b 1423 } else {
ce4e655d 1424 return $self->maybe_parens_func("$our_local", $text, $cx, 16);
e8d3f51b 1425 }
6e90668e 1426 } else {
c8ec376c 1427 return $need_parens ? "($text)" : $text;
a798dbf2 1428 }
a798dbf2
MB
1429}
1430
3ed82cfc
GS
1431sub maybe_targmy {
1432 my $self = shift;
1433 my($op, $cx, $func, @args) = @_;
1434 if ($op->private & OPpTARGET_MY) {
1435 my $var = $self->padname($op->targ);
1436 my $val = $func->($self, $op, 7, @args);
1437 return $self->maybe_parens("$var = $val", $cx, 7);
1438 } else {
1439 return $func->($self, $op, $cx, @args);
1440 }
1441}
1442
6e90668e
SM
1443sub padname_sv {
1444 my $self = shift;
1445 my $targ = shift;
d989cdac 1446 return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
6e90668e
SM
1447}
1448
1449sub maybe_my {
1450 my $self = shift;
8db6f480 1451 my($op, $cx, $text, $padname, $forbid_parens) = @_;
c8ec376c
FC
1452 # The @a in \(@a) isn't in ref context, but only when the
1453 # parens are there.
1454 my $need_parens = !$forbid_parens && $self->{'in_refgen'}
1455 && $op->name =~ /[ah]v\z/
1456 && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
0ed5b3c8
FC
1457 # The @a in \my @a must not have parens.
1458 if (!$need_parens && $self->{'in_refgen'}) {
1459 $forbid_parens = 1;
1460 }
4c1f658f 1461 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
bcff4148
FC
1462 # Check $padname->FLAGS for statehood, rather than $op->private,
1463 # because enteriter ops do not carry the flag.
3188a821 1464 my $my =
bcff4148 1465 $self->keyword($padname->FLAGS & SVpad_STATE ? "state" : "my");
56cd2ef8
FC
1466 if ($padname->FLAGS & SVpad_TYPED) {
1467 $my .= ' ' . $padname->SvSTASH->NAME;
1468 }
c8ec376c
FC
1469 if ($need_parens) {
1470 return "$my($text)";
1471 } elsif ($forbid_parens || want_scalar($op)) {
3462b4ac 1472 return "$my $text";
e8d3f51b 1473 } else {
3462b4ac 1474 return $self->maybe_parens_func($my, $text, $cx, 16);
e8d3f51b 1475 }
6e90668e 1476 } else {
c8ec376c 1477 return $need_parens ? "($text)" : $text;
6e90668e
SM
1478 }
1479}
1480
9d2c6865
SM
1481# The following OPs don't have functions:
1482
1483# pp_padany -- does not exist after parsing
9d2c6865 1484
2ae48fff
RGS
1485sub AUTOLOAD {
1486 if ($AUTOLOAD =~ s/^.*::pp_//) {
5e8c3db2
FC
1487 warn "unexpected OP_".
1488 ($_[1]->type == OP_CUSTOM ? "CUSTOM ($AUTOLOAD)" : uc $AUTOLOAD);
2ae48fff
RGS
1489 return "XXX";
1490 } else {
1491 die "Undefined subroutine $AUTOLOAD called";
1492 }
9d2c6865 1493}
6e90668e 1494
611c1e95
IZ
1495sub DESTROY {} # Do not AUTOLOAD
1496
ce4e655d
RH
1497# $root should be the op which represents the root of whatever
1498# we're sequencing here. If it's undefined, then we don't append
1499# any subroutine declarations to the deparsed ops, otherwise we
1500# append appropriate declarations.
58cccf98 1501sub lineseq {
93a8ff62 1502 my($self, $root, $cx, @ops) = @_;
58cccf98 1503 my($expr, @exprs);
ce4e655d
RH
1504
1505 my $out_cop = $self->{'curcop'};
1506 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1507 my $limit_seq;
1508 if (defined $root) {
1509 $limit_seq = $out_seq;
76df5e8f
DM
1510 my $nseq;
1511 $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
ce4e655d
RH
1512 $limit_seq = $nseq if !defined($limit_seq)
1513 or defined($nseq) && $nseq < $limit_seq;
1514 }
1515 $limit_seq = $self->{'limit_seq'}
1516 if defined($self->{'limit_seq'})
1517 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1518 local $self->{'limit_seq'} = $limit_seq;
09d856fb
CK
1519
1520 $self->walk_lineseq($root, \@ops,
1521 sub { push @exprs, $_[0]} );
1522
93a8ff62
FC
1523 my $sep = $cx ? '; ' : ";\n";
1524 my $body = join($sep, grep {length} @exprs);
ce4e655d 1525 my $subs = "";
67fc2416 1526 if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
ce4e655d
RH
1527 $subs = join "\n", $self->seq_subs($limit_seq);
1528 }
93a8ff62 1529 return join($sep, grep {length} $body, $subs);
6e90668e
SM
1530}
1531
58cccf98 1532sub scopeop {
d989cdac 1533 my($real_block, $self, $op, $cx) = @_;
58cccf98
SM
1534 my $kid;
1535 my @kids;
a0405c92 1536
0ced6c29
RGS
1537 local(@$self{qw'curstash warnings hints hinthash'})
1538 = @$self{qw'curstash warnings hints hinthash'} if $real_block;
58cccf98
SM
1539 if ($real_block) {
1540 $kid = $op->first->sibling; # skip enter
1541 if (is_miniwhile($kid)) {
1542 my $top = $kid->first;
1543 my $name = $top->name;
1544 if ($name eq "and") {
7741ceed 1545 $name = $self->keyword("while");
58cccf98 1546 } elsif ($name eq "or") {
7741ceed 1547 $name = $self->keyword("until");
58cccf98 1548 } else { # no conditional -> while 1 or until 0
7741ceed
FC
1549 return $self->deparse($top->first, 1) . " "
1550 . $self->keyword("while") . " 1";
58cccf98
SM
1551 }
1552 my $cond = $top->first;
1553 my $body = $cond->sibling->first; # skip lineseq
1554 $cond = $self->deparse($cond, 1);
1555 $body = $self->deparse($body, 1);
1556 return "$body $name $cond";
6e90668e 1557 }
58cccf98
SM
1558 } else {
1559 $kid = $op->first;
1560 }
1561 for (; !null($kid); $kid = $kid->sibling) {
1562 push @kids, $kid;
6e90668e 1563 }
d989cdac 1564 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
73582821 1565 my $body = $self->lineseq($op, 0, @kids);
3188a821
FC
1566 return is_lexical_subs(@kids)
1567 ? $body
1568 : ($self->lex_in_scope("&do") ? "CORE::do" : "do")
1569 . " {\n\t$body\n\b}";
9d2c6865 1570 } else {
93a8ff62 1571 my $lineseq = $self->lineseq($op, $cx, @kids);
7a9b44b9 1572 return (length ($lineseq) ? "$lineseq;" : "");
6e90668e 1573 }
6e90668e
SM
1574}
1575
ce4e655d 1576sub pp_scope { scopeop(0, @_); }
58cccf98
SM
1577sub pp_lineseq { scopeop(0, @_); }
1578sub pp_leave { scopeop(1, @_); }
9d2c6865 1579
d989cdac
SM
1580# This is a special case of scopeop and lineseq, for the case of the
1581# main_root. The difference is that we print the output statements as
1582# soon as we get them, for the sake of impatient users.
1583sub deparse_root {
1584 my $self = shift;
1585 my($op) = @_;
0ced6c29
RGS
1586 local(@$self{qw'curstash warnings hints hinthash'})
1587 = @$self{qw'curstash warnings hints hinthash'};
d989cdac 1588 my @kids;
4ca8de37 1589 return if null $op->first; # Can happen, e.g., for Bytecode without -k
d989cdac
SM
1590 for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
1591 push @kids, $kid;
1592 }
09d856fb 1593 $self->walk_lineseq($op, \@kids,
4b1385ee 1594 sub { return unless length $_[0];
5e617af5 1595 print $self->indent($_[0].';');
4b1385ee 1596 print "\n"
5e617af5 1597 unless $_[1] == $#kids;
09d856fb
CK
1598 });
1599}
1600
1601sub walk_lineseq {
1602 my ($self, $op, $kids, $callback) = @_;
1603 my @kids = @$kids;
d989cdac
SM
1604 for (my $i = 0; $i < @kids; $i++) {
1605 my $expr = "";
1606 if (is_state $kids[$i]) {
09d856fb 1607 $expr = $self->deparse($kids[$i++], 0);
d989cdac 1608 if ($i > $#kids) {
09d856fb 1609 $callback->($expr, $i);
d989cdac
SM
1610 last;
1611 }
1612 }
1613 if (is_for_loop($kids[$i])) {
eae48c89
Z
1614 $callback->($expr . $self->for_loop($kids[$i], 0),
1615 $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
d989cdac
SM
1616 next;
1617 }
6b6b21da 1618 my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2);
34b54951 1619 $expr2 =~ s/^sub :(?!:)/+sub :/; # statement label otherwise
6b6b21da 1620 $expr .= $expr2;
09d856fb 1621 $callback->($expr, $i);
d989cdac
SM
1622 }
1623}
1624
6e90668e
SM
1625# The BEGIN {} is used here because otherwise this code isn't executed
1626# when you run B::Deparse on itself.
1627my %globalnames;
1628BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1629 "ENV", "ARGV", "ARGVOUT", "_"); }
1630
1631sub gv_name {
1632 my $self = shift;
1633 my $gv = shift;
b89b7257 1634 my $raw = shift;
32cc5cd1
FC
1635#Carp::confess() unless ref($gv) eq "B::GV";
1636 my $cv = $gv->FLAGS & SVf_ROK ? $gv->RV : 0;
1637 my $stash = ($cv || $gv)->STASH->NAME;
1638 my $name = $raw
1639 ? $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME
1640 : $cv
1641 ? B::safename($cv->NAME_HEK || $cv->GV->NAME)
1642 : $gv->SAFENAME;
8b2d6640
FC
1643 if ($stash eq 'main' && $name =~ /^::/) {
1644 $stash = '::';
1645 }
b861b87f
FC
1646 elsif (($stash eq 'main'
1647 && ($globalnames{$name} || $name =~ /^[^A-Za-z_:]/))
8b2d6640
FC
1648 or ($stash eq $self->{'curstash'} && !$globalnames{$name}
1649 && ($stash eq 'main' || $name !~ /::/))
b861b87f 1650 )
9d2c6865 1651 {
6e90668e
SM
1652 $stash = "";
1653 } else {
1654 $stash = $stash . "::";
a798dbf2 1655 }
b89b7257 1656 if (!$raw and $name =~ /^(\^..|{)/) {
083bda02 1657 $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
6e90668e
SM
1658 }
1659 return $stash . $name;
a798dbf2
MB
1660}
1661
8510e997 1662# Return the name to use for a stash variable.
415d4c68
FC
1663# If a lexical with the same name is in scope, or
1664# if strictures are enabled, it may need to be
8510e997
RH
1665# fully-qualified.
1666sub stash_variable {
bb8996b8 1667 my ($self, $prefix, $name, $cx) = @_;
8510e997
RH
1668
1669 return "$prefix$name" if $name =~ /::/;
1670
d49c3562 1671 unless ($prefix eq '$' || $prefix eq '@' || $prefix eq '&' || #'
8510e997
RH
1672 $prefix eq '%' || $prefix eq '$#') {
1673 return "$prefix$name";
1674 }
1675
8c2e27d2 1676 if ($name =~ /^[^[:alpha:]+-]$/) {
61154ac0
FC
1677 if (defined $cx && $cx == 26) {
1678 if ($prefix eq '@') {
bb8996b8
HY
1679 return "$prefix\{$name}";
1680 }
61154ac0
FC
1681 elsif ($name eq '#') { return '${#}' } # "${#}a" vs "$#a"
1682 }
1683 if ($prefix eq '$#') {
6ec73527 1684 return "\$#{$name}";
61154ac0 1685 }
6ec73527 1686 }
bb8996b8 1687
415d4c68 1688 return $prefix . $self->maybe_qualify($prefix, $name);
8510e997
RH
1689}
1690
be6cf5cf
FC
1691# Return just the name, without the prefix. It may be returned as a quoted
1692# string. The second return value is a boolean indicating that.
1693sub stash_variable_name {
1694 my($self, $prefix, $gv) = @_;
1695 my $name = $self->gv_name($gv, 1);
415d4c68 1696 $name = $self->maybe_qualify($prefix,$name);
be6cf5cf
FC
1697 if ($name =~ /^(?:\S|(?!\d)[\ca-\cz]?(?:\w|::)*|\d+)\z/) {
1698 $name =~ s/^([\ca-\cz])/'^'.($1|'@')/e;
1699 $name =~ /^(\^..|{)/ and $name = "{$name}";
1700 return $name, 0; # not quoted
1701 }
1702 else {
7741ceed 1703 single_delim("q", "'", $name, $self), 1;
be6cf5cf
FC
1704 }
1705}
1706
415d4c68
FC
1707sub maybe_qualify {
1708 my ($self,$prefix,$name) = @_;
1709 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1710 return $name if !$prefix || $name =~ /::/;
1711 return $self->{'curstash'}.'::'. $name
1712 if
36727b53
FC
1713 $name =~ /^(?!\d)\w/ # alphabetic
1714 && $v !~ /^\$[ab]\z/ # not $a or $b
415d4c68
FC
1715 && !$globalnames{$name} # not a global name
1716 && $self->{hints} & $strict_bits{vars} # strict vars
1717 && !$self->lex_in_scope($v,1) # no "our"
1718 or $self->lex_in_scope($v); # conflicts with "my" variable
1719 return $name;
1720}
1721
8510e997 1722sub lex_in_scope {
415d4c68
FC
1723 my ($self, $name, $our) = @_;
1724 substr $name, 0, 0, = $our ? 'o' : 'm'; # our/my
8510e997
RH
1725 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1726
6ec152c3 1727 return 0 if !defined($self->{'curcop'});
8510e997
RH
1728 my $seq = $self->{'curcop'}->cop_seq;
1729 return 0 if !exists $self->{'curcvlex'}{$name};
1730 for my $a (@{$self->{'curcvlex'}{$name}}) {
1731 my ($st, $en) = @$a;
1732 return 1 if $seq > $st && $seq <= $en;
1733 }
1734 return 0;
1735}
1736
1737sub populate_curcvlex {
1738 my $self = shift;
ce4e655d 1739 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
7dafbf52
DM
1740 my $padlist = $cv->PADLIST;
1741 # an undef CV still in lexical chain
1742 next if class($padlist) eq "SPECIAL";
1743 my @padlist = $padlist->ARRAY;
8510e997
RH
1744 my @ns = $padlist[0]->ARRAY;
1745
1746 for (my $i=0; $i<@ns; ++$i) {
1747 next if class($ns[$i]) eq "SPECIAL";
0f2fe21d
RH
1748 if (class($ns[$i]) eq "PV") {
1749 # Probably that pesky lexical @_
1750 next;
1751 }
8510e997 1752 my $name = $ns[$i]->PVX;
679f2252 1753 next unless defined $name;
7dafbf52
DM
1754 my ($seq_st, $seq_en) =
1755 ($ns[$i]->FLAGS & SVf_FAKE)
1756 ? (0, 999999)
809abb02 1757 : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH);
8510e997 1758
415d4c68
FC
1759 push @{$self->{'curcvlex'}{
1760 ($ns[$i]->FLAGS & SVpad_OUR ? 'o' : 'm') . $name
56cd2ef8 1761 }}, [$seq_st, $seq_en, $ns[$i]];
8510e997
RH
1762 }
1763 }
1764}
1765
ce4e655d
RH
1766sub find_scope_st { ((find_scope(@_))[0]); }
1767sub find_scope_en { ((find_scope(@_))[1]); }
1768
1769# Recurses down the tree, looking for pad variable introductions and COPs
1770sub find_scope {
1771 my ($self, $op, $scope_st, $scope_en) = @_;
ff97752d 1772 carp("Undefined op in find_scope") if !defined $op;
ce4e655d
RH
1773 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1774
b6b46d6f
AB
1775 my @queue = ($op);
1776 while(my $op = shift @queue ) {
1777 for (my $o=$op->first; $$o; $o=$o->sibling) {
1778 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1779 my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW);
1780 my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH;
1781 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1782 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1783 return ($scope_st, $scope_en);
1784 }
1785 elsif (is_state($o)) {
1786 my $c = $o->cop_seq;
1787 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1788 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1789 return ($scope_st, $scope_en);
1790 }
1791 elsif ($o->flags & OPf_KIDS) {
1792 unshift (@queue, $o);
1793 }
34a48b4b
RH
1794 }
1795 }
ce4e655d
RH
1796
1797 return ($scope_st, $scope_en);
34a48b4b
RH
1798}
1799
1800# Returns a list of subs which should be inserted before the COP
1801sub cop_subs {
1802 my ($self, $op, $out_seq) = @_;
1803 my $seq = $op->cop_seq;
8635e3c2
FC
1804 if ($] < 5.021006) {
1805 # If we have nephews, then our sequence number indicates
1806 # the cop_seq of the end of some sort of scope.
1807 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
ce4e655d
RH
1808 and my $nseq = $self->find_scope_st($op->sibling) ) {
1809 $seq = $nseq;
8635e3c2 1810 }
34a48b4b
RH
1811 }
1812 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1813 return $self->seq_subs($seq);
1814}
1815
1816sub seq_subs {
1817 my ($self, $seq) = @_;
1818 my @text;
1819#push @text, "# ($seq)\n";
1820
ce4e655d 1821 return "" if !defined $seq;
d88d1fe0 1822 my @pending;
34a48b4b
RH
1823 while (scalar(@{$self->{'subs_todo'}})
1824 and $seq > $self->{'subs_todo'}[0][0]) {
d88d1fe0 1825 my $cv = $self->{'subs_todo'}[0][1];
d4f1bfe7
FC
1826 # Skip the OUTSIDE check for lexical subs. We may be deparsing a
1827 # cloned anon sub with lexical subs declared in it, in which case
1828 # the OUTSIDE pointer points to the anon protosub.
c310a5ab 1829 my $lexical = ref $self->{'subs_todo'}[0][3];
d4f1bfe7
FC
1830 my $outside = !$lexical && $cv && $cv->OUTSIDE;
1831 if (!$lexical and $cv
1832 and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}})
1833 {
d88d1fe0
FC
1834 push @pending, shift @{$self->{'subs_todo'}};
1835 next;
1836 }
34a48b4b
RH
1837 push @text, $self->next_todo;
1838 }
d88d1fe0 1839 unshift @{$self->{'subs_todo'}}, @pending;
34a48b4b
RH
1840 return @text;
1841}
1842
95c04cde
NC
1843sub _features_from_bundle {
1844 my ($hints, $hh) = @_;
1873980a 1845 foreach (@{$feature::feature_bundle{@feature::hint_bundles[$hints >> $feature::hint_shift]}}) {
95c04cde
NC
1846 $hh->{$feature::feature{$_}} = 1;
1847 }
1848 return $hh;
1849}
1850
08c6f5ec 1851# Notice how subs and formats are inserted between statements here;
bc6b2ef6 1852# also $[ assignments and pragmas.
6e90668e
SM
1853sub pp_nextstate {
1854 my $self = shift;
9d2c6865 1855 my($op, $cx) = @_;
34a48b4b 1856 $self->{'curcop'} = $op;
6e90668e 1857 my @text;
34a48b4b 1858 push @text, $self->cop_subs($op);
4b1385ee
FC
1859 if (@text) {
1860 # Special marker to swallow up the semicolon
5e617af5 1861 push @text, "\cK";
4b1385ee 1862 }
11faa288 1863 my $stash = $op->stashpv;
6e90668e 1864 if ($stash ne $self->{'curstash'}) {
7741ceed 1865 push @text, $self->keyword("package") . " $stash;\n";
6e90668e
SM
1866 $self->{'curstash'} = $stash;
1867 }
08c6f5ec 1868
bc6b2ef6
Z
1869 if (OPpCONST_ARYBASE && $self->{'arybase'} != $op->arybase) {
1870 push @text, '$[ = '. $op->arybase .";\n";
1871 $self->{'arybase'} = $op->arybase;
1872 }
1873
7a9b44b9
RH
1874 my $warnings = $op->warnings;
1875 my $warning_bits;
1876 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
810aef70 1877 $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
7a9b44b9 1878 }
e31885a0 1879 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
810aef70 1880 $warning_bits = $warnings::NONE;
7a9b44b9 1881 }
e31885a0
RH
1882 elsif ($warnings->isa("B::SPECIAL")) {
1883 $warning_bits = undef;
1884 }
7a9b44b9 1885 else {
34a48b4b 1886 $warning_bits = $warnings->PV & WARN_MASK;
7a9b44b9
RH
1887 }
1888
e31885a0
RH
1889 if (defined ($warning_bits) and
1890 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
7741ceed
FC
1891 push @text,
1892 $self->declare_warnings($self->{'warnings'}, $warning_bits);
7a9b44b9
RH
1893 $self->{'warnings'} = $warning_bits;
1894 }
1895
2be95ceb 1896 my $hints = $] < 5.008009 ? $op->private : $op->hints;
0bb01b05 1897 my $old_hints = $self->{'hints'};
2be95ceb 1898 if ($self->{'hints'} != $hints) {
7741ceed 1899 push @text, $self->declare_hints($self->{'hints'}, $hints);
2be95ceb 1900 $self->{'hints'} = $hints;
a0405c92
RH
1901 }
1902
0bb01b05
FC
1903 my $newhh;
1904 if ($] > 5.009) {
1905 $newhh = $op->hints_hash->HASH;
1906 }
1907
1908 if ($] >= 5.015006) {
1909 # feature bundle hints
149758b3
NC
1910 my $from = $old_hints & $feature::hint_mask;
1911 my $to = $ hints & $feature::hint_mask;
0bb01b05 1912 if ($from != $to) {
149758b3 1913 if ($to == $feature::hint_mask) {
0bb01b05
FC
1914 if ($self->{'hinthash'}) {
1915 delete $self->{'hinthash'}{$_}
1916 for grep /^feature_/, keys %{$self->{'hinthash'}};
1917 }
1918 else { $self->{'hinthash'} = {} }
95c04cde
NC
1919 $self->{'hinthash'}
1920 = _features_from_bundle($from, $self->{'hinthash'});
0bb01b05
FC
1921 }
1922 else {
1923 my $bundle =
1924 $feature::hint_bundles[$to >> $feature::hint_shift];
1925 $bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12
7741ceed 1926 push @text,
127ce1cd 1927 $self->keyword("no") . " feature ':all';\n",
7741ceed 1928 $self->keyword("use") . " feature ':$bundle';\n";
0bb01b05
FC
1929 }
1930 }
1931 }
1932
1933 if ($] > 5.009) {
7741ceed 1934 push @text, $self->declare_hinthash(
0bb01b05
FC
1935 $self->{'hinthash'}, $newhh,
1936 $self->{indent_size}, $self->{hints},
1937 );
1938 $self->{'hinthash'} = $newhh;
0ced6c29
RGS
1939 }
1940
d989cdac
SM
1941 # This should go after of any branches that add statements, to
1942 # increase the chances that it refers to the same line it did in
1943 # the original program.
e56a605e 1944 if ($self->{'linenums'} && $cx != .5) { # $cx == .5 means in a format
d989cdac
SM
1945 push @text, "\f#line " . $op->line .
1946 ' "' . $op->file, qq'"\n';
1947 }
1948
98a1a137
Z
1949 push @text, $op->label . ": " if $op->label;
1950
6e90668e
SM
1951 return join("", @text);
1952}
1953
08c6f5ec 1954sub declare_warnings {
7741ceed 1955 my ($self, $from, $to) = @_;
e6f1f756 1956 if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
7741ceed 1957 return $self->keyword("use") . " warnings;\n";
a0405c92 1958 }
e6f1f756 1959 elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
7741ceed 1960 return $self->keyword("no") . " warnings;\n";
a0405c92 1961 }
5e617af5 1962 return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n\cK";
a0405c92
RH
1963}
1964
1965sub declare_hints {
7741ceed 1966 my ($self, $from, $to) = @_;
a0035eb8
RH
1967 my $use = $to & ~$from;
1968 my $no = $from & ~$to;
1969 my $decls = "";
1970 for my $pragma (hint_pragmas($use)) {
7741ceed 1971 $decls .= $self->keyword("use") . " $pragma;\n";
a0035eb8
RH
1972 }
1973 for my $pragma (hint_pragmas($no)) {
7741ceed 1974 $decls .= $self->keyword("no") . " $pragma;\n";
a0035eb8
RH
1975 }
1976 return $decls;
1977}
1978
493c23c6
NC
1979# Internal implementation hints that the core sets automatically, so don't need
1980# (or want) to be passed back to the user
1981my %ignored_hints = (
1982 'open<' => 1,
1983 'open>' => 1,
dca6062a 1984 ':' => 1,
1c74777c
FC
1985 'strict/refs' => 1,
1986 'strict/subs' => 1,
1987 'strict/vars' => 1,
2e8342de 1988);
493c23c6 1989
a8095af7
FC
1990my %rev_feature;
1991
0ced6c29 1992sub declare_hinthash {
7741ceed 1993 my ($self, $from, $to, $indent, $hints) = @_;
a8095af7 1994 my $doing_features =
149758b3 1995 ($hints & $feature::hint_mask) == $feature::hint_mask;
0ced6c29 1996 my @decls;
a8095af7
FC
1997 my @features;
1998 my @unfeatures; # bugs?
0bb01b05 1999 for my $key (sort keys %$to) {
493c23c6 2000 next if $ignored_hints{$key};
a8095af7
FC
2001 my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6;
2002 next if $is_feature and not $doing_features;
04be0204 2003 if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) {
a8095af7 2004 push(@features, $key), next if $is_feature;
035146a3 2005 push @decls,
7741ceed 2006 qq(\$^H{) . single_delim("q", "'", $key, $self) . qq(} = )
035146a3
FC
2007 . (
2008 defined $to->{$key}
7741ceed 2009 ? single_delim("q", "'", $to->{$key}, $self)
035146a3
FC
2010 : 'undef'
2011 )
04be0204 2012 . qq(;);
0ced6c29
RGS
2013 }
2014 }
0bb01b05 2015 for my $key (sort keys %$from) {
493c23c6 2016 next if $ignored_hints{$key};
a8095af7
FC
2017 my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6;
2018 next if $is_feature and not $doing_features;
0ced6c29 2019 if (!exists $to->{$key}) {
a8095af7 2020 push(@unfeatures, $key), next if $is_feature;
0ced6c29
RGS
2021 push @decls, qq(delete \$^H{'$key'};);
2022 }
2023 }
a8095af7
FC
2024 my @ret;
2025 if (@features || @unfeatures) {
a8095af7
FC
2026 if (!%rev_feature) { %rev_feature = reverse %feature::feature }
2027 }
2028 if (@features) {
7741ceed 2029 push @ret, $self->keyword("use") . " feature "
a8095af7
FC
2030 . join(", ", map "'$rev_feature{$_}'", @features) . ";\n";
2031 }
2032 if (@unfeatures) {
7741ceed 2033 push @ret, $self->keyword("no") . " feature "
a8095af7
FC
2034 . join(", ", map "'$rev_feature{$_}'", @unfeatures)
2035 . ";\n";
2036 }
2037 @decls and
2038 push @ret,
5e617af5 2039 join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n\cK";
a8095af7 2040 return @ret;
0ced6c29
RGS
2041}
2042
a0035eb8
RH
2043sub hint_pragmas {
2044 my ($bits) = @_;
415d4c68 2045 my (@pragmas, @strict);
a0035eb8 2046 push @pragmas, "integer" if $bits & 0x1;
415d4c68
FC
2047 for (sort keys %strict_bits) {
2048 push @strict, "'$_'" if $bits & $strict_bits{$_};
2049 }
2050 if (@strict == keys %strict_bits) {
2051 push @pragmas, "strict";
2052 }
2053 elsif (@strict) {
2054 push @pragmas, "strict " . join ', ', @strict;
2055 }
a0035eb8
RH
2056 push @pragmas, "bytes" if $bits & 0x8;
2057 return @pragmas;
08c6f5ec
RH
2058}
2059
6e90668e 2060sub pp_dbstate { pp_nextstate(@_) }
3f872cb9 2061sub pp_setstate { pp_nextstate(@_) }
6e90668e
SM
2062
2063sub pp_unstack { return "" } # see also leaveloop
2064
80e3f4ad
FC
2065my %feature_keywords = (
2066 # keyword => 'feature',
2067 state => 'state',
2068 say => 'say',
2069 given => 'switch',
2070 when => 'switch',
2071 default => 'switch',
e36901c8 2072 break => 'switch',
7d789282 2073 evalbytes=>'evalbytes',
84ed0108 2074 __SUB__ => '__SUB__',
838f2281 2075 fc => 'fc',
80e3f4ad
FC
2076);
2077
3ac5308a
DM
2078# keywords that are strong and also have a prototype
2079#
2080my %strong_proto_keywords = map { $_ => 1 } qw(
3ac5308a
DM
2081 pos
2082 prototype
2083 scalar
2084 study
2085 undef
2086);
2087
a958cfbb
FC
2088sub feature_enabled {
2089 my($self,$name) = @_;
223b1722 2090 my $hh;
149758b3
NC
2091 my $hints = $self->{hints} & $feature::hint_mask;
2092 if ($hints && $hints != $feature::hint_mask) {
1873980a 2093 $hh = _features_from_bundle($hints);
223b1722
FC
2094 }
2095 elsif ($hints) { $hh = $self->{'hinthash'} }
a958cfbb
FC
2096 return $hh && $hh->{"feature_$feature_keywords{$name}"}
2097}
2098
2099sub keyword {
2100 my $self = shift;
2101 my $name = shift;
2102 return $name if $name =~ /^CORE::/; # just in case
2103 if (exists $feature_keywords{$name}) {
2104 return "CORE::$name" if not $self->feature_enabled($name);
80e3f4ad 2105 }
7741ceed
FC
2106 # This sub may be called for a program that has no nextstate ops. In
2107 # that case we may have a lexical sub named no/use/sub in scope but
2108 # but $self->lex_in_scope will return false because it depends on the
2109 # current nextstate op. So we need this alternate method if there is
2110 # no current cop.
2111 if (!$self->{'curcop'}) {
2112 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
2113 return "CORE::$name" if exists $self->{'curcvlex'}{"m&$name"}
2114 || exists $self->{'curcvlex'}{"o&$name"};
2115 } elsif ($self->lex_in_scope("&$name")
2116 || $self->lex_in_scope("&$name", 1)) {
3188a821
FC
2117 return "CORE::$name";
2118 }
3ac5308a
DM
2119 if ($strong_proto_keywords{$name}
2120 || ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
2121 && !defined eval{prototype "CORE::$name"})
4a1ac32e
FC
2122 ) { return $name }
2123 if (
2124 exists $self->{subs_declared}{$name}
2125 or
2126 exists &{"$self->{curstash}::$name"}
2127 ) {
2128 return "CORE::$name"
2129 }
2130 return $name;
2131}
2132
6e90668e
SM
2133sub baseop {
2134 my $self = shift;
9d2c6865 2135 my($op, $cx, $name) = @_;
4a1ac32e 2136 return $self->keyword($name);
6e90668e
SM
2137}
2138
ddb55548 2139sub pp_stub { "()" }
6e90668e
SM
2140sub pp_wantarray { baseop(@_, "wantarray") }
2141sub pp_fork { baseop(@_, "fork") }
3ed82cfc
GS
2142sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
2143sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
2144sub pp_time { maybe_targmy(@_, \&baseop, "time") }
6e90668e
SM
2145sub pp_tms { baseop(@_, "times") }
2146sub pp_ghostent { baseop(@_, "gethostent") }
2147sub pp_gnetent { baseop(@_, "getnetent") }
2148sub pp_gprotoent { baseop(@_, "getprotoent") }
2149sub pp_gservent { baseop(@_, "getservent") }
2150sub pp_ehostent { baseop(@_, "endhostent") }
2151sub pp_enetent { baseop(@_, "endnetent") }
2152sub pp_eprotoent { baseop(@_, "endprotoent") }
2153sub pp_eservent { baseop(@_, "endservent") }
2154sub pp_gpwent { baseop(@_, "getpwent") }
2155sub pp_spwent { baseop(@_, "setpwent") }
2156sub pp_epwent { baseop(@_, "endpwent") }
2157sub pp_ggrent { baseop(@_, "getgrent") }
2158sub pp_sgrent { baseop(@_, "setgrent") }
2159sub pp_egrent { baseop(@_, "endgrent") }
2160sub pp_getlogin { baseop(@_, "getlogin") }
2161
2162sub POSTFIX () { 1 }
2163
9d2c6865
SM
2164# I couldn't think of a good short name, but this is the category of
2165# symbolic unary operators with interesting precedence
2166
2167sub pfixop {
2168 my $self = shift;
2169 my($op, $cx, $name, $prec, $flags) = (@_, 0);
2170 my $kid = $op->first;
2171 $kid = $self->deparse($kid, $prec);
843b15cc
FC
2172 return $self->maybe_parens(($flags & POSTFIX)
2173 ? "$kid$name"
2174 # avoid confusion with filetests
2175 : $name eq '-'
2176 && $kid =~ /^[a-zA-Z](?!\w)/
2177 ? "$name($kid)"
2178 : "$name$kid",
9d2c6865
SM
2179 $cx, $prec);
2180}
2181
2182sub pp_preinc { pfixop(@_, "++", 23) }
2183sub pp_predec { pfixop(@_, "--", 23) }
3ed82cfc
GS
2184sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
2185sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
9d2c6865
SM
2186sub pp_i_preinc { pfixop(@_, "++", 23) }
2187sub pp_i_predec { pfixop(@_, "--", 23) }
3ed82cfc
GS
2188sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
2189sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
68cc8748 2190sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
9d2c6865 2191
3ed82cfc
GS
2192sub pp_negate { maybe_targmy(@_, \&real_negate) }
2193sub real_negate {
9d2c6865
SM
2194 my $self = shift;
2195 my($op, $cx) = @_;
3f872cb9 2196 if ($op->first->name =~ /^(i_)?negate$/) {
9d2c6865
SM
2197 # avoid --$x
2198 $self->pfixop($op, $cx, "-", 21.5);
2199 } else {
2200 $self->pfixop($op, $cx, "-", 21);
2201 }
2202}
2203sub pp_i_negate { pp_negate(@_) }
2204
2205sub pp_not {
2206 my $self = shift;
2207 my($op, $cx) = @_;
2208 if ($cx <= 4) {
1cabb3b3 2209 $self->listop($op, $cx, "not", $op->first);
9d2c6865
SM
2210 } else {
2211 $self->pfixop($op, $cx, "!", 21);
2212 }
2213}
2214
6e90668e
SM
2215sub unop {
2216 my $self = shift;
9c56d9ea 2217 my($op, $cx, $name, $nollafr) = @_;
6e90668e 2218 my $kid;
9d2c6865 2219 if ($op->flags & OPf_KIDS) {
aaf643ce 2220 $kid = $op->first;
1c85afce
YO
2221 if (not $name) {
2222 # this deals with 'boolkeys' right now
2223 return $self->deparse($kid,$cx);
2224 }
deb20ba3
RGS
2225 my $builtinname = $name;
2226 $builtinname =~ /^CORE::/ or $builtinname = "CORE::$name";
2227 if (defined prototype($builtinname)
9cef6114 2228 && $builtinname ne 'CORE::readline'
deb20ba3 2229 && prototype($builtinname) =~ /^;?\*/
e31885a0
RH
2230 && $kid->name eq "rv2gv") {
2231 $kid = $kid->first;
2232 }
2233
9c56d9ea 2234 if ($nollafr) {
917a8f4f
FC
2235 if (($kid = $self->deparse($kid, 16)) !~ s/^\cS//) {
2236 # require foo() is a syntax error.
2237 $kid =~ /^(?!\d)\w/ and $kid = "($kid)";
2238 }
9c56d9ea
FC
2239 return $self->maybe_parens(
2240 $self->keyword($name) . " $kid", $cx, 16
2241 );
2242 }
9d2c6865 2243 return $self->maybe_parens_unop($name, $kid, $cx);
6e90668e 2244 } else {
4d8ac5c7
FC
2245 return $self->maybe_parens(
2246 $self->keyword($name) . ($op->flags & OPf_SPECIAL ? "()" : ""),
2247 $cx, 16,
2248 );
6e90668e 2249 }
6e90668e
SM
2250}
2251
3ed82cfc
GS
2252sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
2253sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
2254sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
2255sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
6e90668e
SM
2256sub pp_defined { unop(@_, "defined") }
2257sub pp_undef { unop(@_, "undef") }
2258sub pp_study { unop(@_, "study") }
6e90668e
SM
2259sub pp_ref { unop(@_, "ref") }
2260sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
2261
3ed82cfc
GS
2262sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
2263sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
2264sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
6e90668e 2265sub pp_srand { unop(@_, "srand") }
3ed82cfc
GS
2266sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
2267sub pp_log { maybe_targmy(@_, \&unop, "log") }
2268sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
2269sub pp_int { maybe_targmy(@_, \&unop, "int") }
2270sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
2271sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
2272sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
2273
2274sub pp_length { maybe_targmy(@_, \&unop, "length") }
2275sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
2276sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
6e90668e
SM
2277
2278sub pp_each { unop(@_, "each") }
2279sub pp_values { unop(@_, "values") }
2280sub pp_keys { unop(@_, "keys") }
09dcfa7d 2281{ no strict 'refs'; *{"pp_r$_"} = *{"pp_$_"} for qw< keys each values >; }
1c85afce
YO
2282sub pp_boolkeys {
2283 # no name because its an optimisation op that has no keyword
2284 unop(@_,"");
2285}
644741fd
NC
2286sub pp_aeach { unop(@_, "each") }
2287sub pp_avalues { unop(@_, "values") }
2288sub pp_akeys { unop(@_, "keys") }
6e90668e
SM
2289sub pp_pop { unop(@_, "pop") }
2290sub pp_shift { unop(@_, "shift") }
2291
2292sub pp_caller { unop(@_, "caller") }
2293sub pp_reset { unop(@_, "reset") }
2294sub pp_exit { unop(@_, "exit") }
2295sub pp_prototype { unop(@_, "prototype") }
2296
2297sub pp_close { unop(@_, "close") }
2298sub pp_fileno { unop(@_, "fileno") }
2299sub pp_umask { unop(@_, "umask") }
6e90668e
SM
2300sub pp_untie { unop(@_, "untie") }
2301sub pp_tied { unop(@_, "tied") }
2302sub pp_dbmclose { unop(@_, "dbmclose") }
2303sub pp_getc { unop(@_, "getc") }
2304sub pp_eof { unop(@_, "eof") }
2305sub pp_tell { unop(@_, "tell") }
2306sub pp_getsockname { unop(@_, "getsockname") }
2307sub pp_getpeername { unop(@_, "getpeername") }
2308
0175f038
FC
2309sub pp_chdir {
2310 my ($self, $op, $cx) = @_;
3c4a43a5 2311 if (($op->flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS)) {
0175f038
FC
2312 my $kw = $self->keyword("chdir");
2313 my $kid = $self->const_sv($op->first)->PV;
2314 my $code = $kw
2315 . ($cx >= 16 || $self->{'parens'} ? "($kid)" : " $kid");
2316 maybe_targmy(@_, sub { $_[3] }, $code);
2317 } else {
2318 maybe_targmy(@_, \&unop, "chdir")
2319 }
2320}
2321
3ed82cfc 2322sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
6e90668e 2323sub pp_readlink { unop(@_, "readlink") }
3ed82cfc 2324sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
6e90668e
SM
2325sub pp_readdir { unop(@_, "readdir") }
2326sub pp_telldir { unop(@_, "telldir") }
2327sub pp_rewinddir { unop(@_, "rewinddir") }
2328sub pp_closedir { unop(@_, "closedir") }
3ed82cfc 2329sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
6e90668e
SM
2330sub pp_localtime { unop(@_, "localtime") }
2331sub pp_gmtime { unop(@_, "gmtime") }
2332sub pp_alarm { unop(@_, "alarm") }
3ed82cfc 2333sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
6e90668e 2334
94bb57f9 2335sub pp_dofile {
9c56d9ea 2336 my $code = unop(@_, "do", 1); # llafr does not apply
8b46c09b 2337 if ($code =~ s/^((?:CORE::)?do) \{/$1({/) { $code .= ')' }
94bb57f9
FC
2338 $code;
2339}
7d789282
FC
2340sub pp_entereval {
2341 unop(
2342 @_,
c7c39989 2343 $_[1]->private & OPpEVAL_BYTES ? 'evalbytes' : "eval"
7d789282
FC
2344 )
2345}
6e90668e
SM
2346
2347sub pp_ghbyname { unop(@_, "gethostbyname") }
2348sub pp_gnbyname { unop(@_, "getnetbyname") }
2349sub pp_gpbyname { unop(@_, "getprotobyname") }
2350sub pp_shostent { unop(@_, "sethostent") }
2351sub pp_snetent { unop(@_, "setnetent") }
2352sub pp_sprotoent { unop(@_, "setprotoent") }
2353sub pp_sservent { unop(@_, "setservent") }
2354sub pp_gpwnam { unop(@_, "getpwnam") }
2355sub pp_gpwuid { unop(@_, "getpwuid") }
2356sub pp_ggrnam { unop(@_, "getgrnam") }
2357sub pp_ggrgid { unop(@_, "getgrgid") }
2358
2359sub pp_lock { unop(@_, "lock") }
2360
0d863452 2361sub pp_continue { unop(@_, "continue"); }
c08f093b 2362sub pp_break { unop(@_, "break"); }
0d863452
RH
2363
2364sub givwhen {
2365 my $self = shift;
2366 my($op, $cx, $givwhen) = @_;
2367
2368 my $enterop = $op->first;
2369 my ($head, $block);
2370 if ($enterop->flags & OPf_SPECIAL) {
80e3f4ad 2371 $head = $self->keyword("default");
0d863452
RH
2372 $block = $self->deparse($enterop->first, 0);
2373 }
2374 else {
2375 my $cond = $enterop->first;
2376 my $cond_str = $self->deparse($cond, 1);
2377 $head = "$givwhen ($cond_str)";
2378 $block = $self->deparse($cond->sibling, 0);
2379 }
2380
2381 return "$head {\n".
2382 "\t$block\n".
2383 "\b}\cK";
2384}
2385
80e3f4ad
FC
2386sub pp_leavegiven { givwhen(@_, $_[0]->keyword("given")); }
2387sub pp_leavewhen { givwhen(@_, $_[0]->keyword("when")); }
0d863452 2388
6e90668e
SM
2389sub pp_exists {
2390 my $self = shift;
9d2c6865 2391 my($op, $cx) = @_;
34a48b4b 2392 my $arg;
3188a821 2393 my $name = $self->keyword("exists");
34a48b4b
RH
2394 if ($op->private & OPpEXISTS_SUB) {
2395 # Checking for the existence of a subroutine
3188a821 2396 return $self->maybe_parens_func($name,
34a48b4b
RH
2397 $self->pp_rv2cv($op->first, 16), $cx, 16);
2398 }
2399 if ($op->flags & OPf_SPECIAL) {
2400 # Array element, not hash element
3188a821 2401 return $self->maybe_parens_func($name,
34a48b4b
RH
2402 $self->pp_aelem($op->first, 16), $cx, 16);
2403 }
3188a821 2404 return $self->maybe_parens_func($name, $self->pp_helem($op->first, 16),
9d2c6865 2405 $cx, 16);
6e90668e
SM
2406}
2407
6e90668e
SM
2408sub pp_delete {
2409 my $self = shift;
9d2c6865 2410 my($op, $cx) = @_;
6e90668e 2411 my $arg;
3188a821 2412 my $name = $self->keyword("delete");
6e90668e 2413 if ($op->private & OPpSLICE) {
34a48b4b
RH
2414 if ($op->flags & OPf_SPECIAL) {
2415 # Deleting from an array, not a hash
3188a821 2416 return $self->maybe_parens_func($name,
34a48b4b
RH
2417 $self->pp_aslice($op->first, 16),
2418 $cx, 16);
2419 }
3188a821 2420 return $self->maybe_parens_func($name,
9d2c6865
SM
2421 $self->pp_hslice($op->first, 16),
2422 $cx, 16);
6e90668e 2423 } else {
34a48b4b
RH
2424 if ($op->flags & OPf_SPECIAL) {
2425 # Deleting from an array, not a hash
3188a821 2426 return $self->maybe_parens_func($name,
34a48b4b
RH
2427 $self->pp_aelem($op->first, 16),
2428 $cx, 16);
2429 }
3188a821 2430 return $self->maybe_parens_func($name,
9d2c6865
SM
2431 $self->pp_helem($op->first, 16),
2432 $cx, 16);
6e90668e 2433 }
6e90668e
SM
2434}
2435
6e90668e
SM
2436sub pp_require {
2437 my $self = shift;
9d2c6865 2438 my($op, $cx) = @_;
d5889722 2439 my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
5e7acd25
FC
2440 my $kid = $op->first;
2441 if ($kid->name eq 'const') {
2442 my $priv = $kid->private;
2443 my $sv = $self->const_sv($kid);
2444 my $arg;
2445 if ($priv & OPpCONST_BARE) {
2446 $arg = $sv->PV;
2447 $arg =~ s[/][::]g;
2448 $arg =~ s/\.pm//g;
2449 } elsif ($priv & OPpCONST_NOVER) {
2450 $opname = $self->keyword('no');
2451 $arg = $self->const($sv, 16);
2452 } elsif ((my $tmp = $self->const($sv, 16)) =~ /^v/) {
2453 $arg = $tmp;
2454 }
2455 if ($arg) {
2456 return $self->maybe_parens("$opname $arg", $cx, 16);
2457 }
2458 }
2459 $self->unop(
41df74e3 2460 $op, $cx,
5e7acd25 2461 $opname,
41df74e3 2462 1, # llafr does not apply
5e7acd25 2463 );
6e90668e
SM
2464}
2465
d989cdac 2466sub pp_scalar {
9d2c6865 2467 my $self = shift;
d9002312 2468 my($op, $cx) = @_;
9d2c6865
SM
2469 my $kid = $op->first;
2470 if (not null $kid->sibling) {
2471 # XXX Was a here-doc
2472 return $self->dquote($op);
2473 }
2474 $self->unop(@_, "scalar");
2475}
2476
2477
6e90668e
SM
2478sub padval {
2479 my $self = shift;
2480 my $targ = shift;
d989cdac 2481 return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
6e90668e
SM
2482}
2483
78c72037
NC
2484sub anon_hash_or_list {
2485 my $self = shift;
d9002312 2486 my($op, $cx) = @_;
78c72037
NC
2487
2488 my($pre, $post) = @{{"anonlist" => ["[","]"],
2489 "anonhash" => ["{","}"]}->{$op->name}};
2490 my($expr, @exprs);
2491 $op = $op->first->sibling; # skip pushmark
2492 for (; !null($op); $op = $op->sibling) {
2493 $expr = $self->deparse($op, 6);
2494 push @exprs, $expr;
2495 }
d9002312
SM
2496 if ($pre eq "{" and $cx < 1) {
2497 # Disambiguate that it's not a block
2498 $pre = "+{";
2499 }
78c72037
NC
2500 return $pre . join(", ", @exprs) . $post;
2501}
2502
2503sub pp_anonlist {
d9002312
SM
2504 my $self = shift;
2505 my ($op, $cx) = @_;
78c72037 2506 if ($op->flags & OPf_SPECIAL) {
d9002312 2507 return $self->anon_hash_or_list($op, $cx);
78c72037
NC
2508 }
2509 warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL";
2510 return 'XXX';
2511}
2512
2513*pp_anonhash = \&pp_anonlist;
2514
6e90668e
SM
2515sub pp_refgen {
2516 my $self = shift;
9d2c6865 2517 my($op, $cx) = @_;
6e90668e 2518 my $kid = $op->first;
3f872cb9 2519 if ($kid->name eq "null") {
01762542
FC
2520 my $anoncode = $kid = $kid->first;
2521 if ($anoncode->name eq "anoncode"
2522 or !null($anoncode = $kid->sibling) and
2523 $anoncode->name eq "anoncode") {
2524 return $self->e_anoncode({ code => $self->padval($anoncode->targ) });
3f872cb9
GS
2525 } elsif ($kid->name eq "pushmark") {
2526 my $sib_name = $kid->sibling->name;
c8ec376c 2527 if ($sib_name eq 'entersub') {
c8c62db7
AD
2528 my $text = $self->deparse($kid->sibling, 1);
2529 # Always show parens for \(&func()), but only with -p otherwise
2530 $text = "($text)" if $self->{'parens'}
2531 or $kid->sibling->private & OPpENTERSUB_AMPER;
2532 return "\\$text";
2533 }
2534 }
6e90668e 2535 }
c8ec376c 2536 local $self->{'in_refgen'} = 1;
9d2c6865 2537 $self->pfixop($op, $cx, "\\", 20);
6e90668e
SM
2538}
2539
09d856fb
CK
2540sub e_anoncode {
2541 my ($self, $info) = @_;
2542 my $text = $self->deparse_sub($info->{code});
7741ceed 2543 return $self->keyword("sub") . " $text";
09d856fb
CK
2544}
2545
6e90668e
SM
2546sub pp_srefgen { pp_refgen(@_) }
2547
2548sub pp_readline {
2549 my $self = shift;
9d2c6865 2550 my($op, $cx) = @_;
6e90668e 2551 my $kid = $op->first;
e31885a0
RH
2552 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
2553 return $self->unop($op, $cx, "readline");
6e90668e
SM
2554}
2555
ad8caead
RGS
2556sub pp_rcatline {
2557 my $self = shift;
2558 my($op) = @_;
d989cdac 2559 return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
ad8caead
RGS
2560}
2561
bd0865ec
GS
2562# Unary operators that can occur as pseudo-listops inside double quotes
2563sub dq_unop {
2564 my $self = shift;
2565 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
2566 my $kid;
2567 if ($op->flags & OPf_KIDS) {
2568 $kid = $op->first;
2569 # If there's more than one kid, the first is an ex-pushmark.
2570 $kid = $kid->sibling if not null $kid->sibling;
2571 return $self->maybe_parens_unop($name, $kid, $cx);
2572 } else {
d989cdac 2573 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
bd0865ec
GS
2574 }
2575}
2576
2577sub pp_ucfirst { dq_unop(@_, "ucfirst") }
2578sub pp_lcfirst { dq_unop(@_, "lcfirst") }
2579sub pp_uc { dq_unop(@_, "uc") }
2580sub pp_lc { dq_unop(@_, "lc") }
3ed82cfc 2581sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
838f2281 2582sub pp_fc { dq_unop(@_, "fc") }
bd0865ec 2583
6e90668e
SM
2584sub loopex {
2585 my $self = shift;
9d2c6865 2586 my ($op, $cx, $name) = @_;
6e90668e 2587 if (class($op) eq "PVOP") {
41df74e3 2588 $name .= " " . $op->pv;
9d2c6865 2589 } elsif (class($op) eq "OP") {
41df74e3 2590 # no-op
6e90668e 2591 } elsif (class($op) eq "UNOP") {
1eb0b7be 2592 (my $kid = $self->deparse($op->first, 7)) =~ s/^\cS//;
df465735
FC
2593 # last foo() is a syntax error.
2594 $kid =~ /^(?!\d)\w/ and $kid = "($kid)";
41df74e3 2595 $name .= " $kid";
6e90668e 2596 }
1eb0b7be 2597 return $self->maybe_parens($name, $cx, 7);
6e90668e
SM
2598}
2599
2600sub pp_last { loopex(@_, "last") }
2601sub pp_next { loopex(@_, "next") }
2602sub pp_redo { loopex(@_, "redo") }
2603sub pp_goto { loopex(@_, "goto") }
266da325 2604sub pp_dump { loopex(@_, "CORE::dump") }
6e90668e
SM
2605
2606sub ftst {
2607 my $self = shift;
9d2c6865 2608 my($op, $cx, $name) = @_;
6e90668e 2609 if (class($op) eq "UNOP") {
e38ccfd9 2610 # Genuine '-X' filetests are exempt from the LLAFR, but not
5830412d
FC
2611 # l?stat()
2612 if ($name =~ /^-/) {
2613 (my $kid = $self->deparse($op->first, 16)) =~ s/^\cS//;
2614 return $self->maybe_parens("$name $kid", $cx, 16);
2615 }
9d2c6865 2616 return $self->maybe_parens_unop($name, $op->first, $cx);
d989cdac 2617 } elsif (class($op) =~ /^(SV|PAD)OP$/) {
9d2c6865 2618 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
6e90668e 2619 } else { # I don't think baseop filetests ever survive ck_ftst, but...
9d2c6865 2620 return $name;
6e90668e 2621 }
6e90668e
SM
2622}
2623
d989cdac
SM
2624sub pp_lstat { ftst(@_, "lstat") }
2625sub pp_stat { ftst(@_, "stat") }
2626sub pp_ftrread { ftst(@_, "-R") }
6e90668e 2627sub pp_ftrwrite { ftst(@_, "-W") }
d989cdac
SM
2628sub pp_ftrexec { ftst(@_, "-X") }
2629sub pp_fteread { ftst(@_, "-r") }
e31885a0 2630sub pp_ftewrite { ftst(@_, "-w") }
d989cdac
SM
2631sub pp_fteexec { ftst(@_, "-x") }
2632sub pp_ftis { ftst(@_, "-e") }
6e90668e
SM
2633sub pp_fteowned { ftst(@_, "-O") }
2634sub pp_ftrowned { ftst(@_, "-o") }
d989cdac
SM
2635sub pp_ftzero { ftst(@_, "-z") }
2636sub pp_ftsize { ftst(@_, "-s") }
2637sub pp_ftmtime { ftst(@_, "-M") }
2638sub pp_ftatime { ftst(@_, "-A") }
2639sub pp_ftctime { ftst(@_, "-C") }
2640sub pp_ftsock { ftst(@_, "-S") }
2641sub pp_ftchr { ftst(@_, "-c") }
2642sub pp_ftblk { ftst(@_, "-b") }
2643sub pp_ftfile { ftst(@_, "-f") }
2644sub pp_ftdir { ftst(@_, "-d") }
2645sub pp_ftpipe { ftst(@_, "-p") }
2646sub pp_ftlink { ftst(@_, "-l") }
2647sub pp_ftsuid { ftst(@_, "-u") }
2648sub pp_ftsgid { ftst(@_, "-g") }
2649sub pp_ftsvtx { ftst(@_, "-k") }
2650sub pp_fttty { ftst(@_, "-t") }
2651sub pp_fttext { ftst(@_, "-T") }
6e90668e
SM
2652sub pp_ftbinary { ftst(@_, "-B") }
2653
a798dbf2 2654sub SWAP_CHILDREN () { 1 }
6e90668e 2655sub ASSIGN () { 2 } # has OP= variant
7013e6ae 2656sub LIST_CONTEXT () { 4 } # Assignment is in list context
6e90668e 2657
9d2c6865
SM
2658my(%left, %right);
2659
2660sub assoc_class {
2661 my $op = shift;
3f872cb9
GS
2662 my $name = $op->name;
2663 if ($name eq "concat" and $op->first->name eq "concat") {
e38ccfd9 2664 # avoid spurious '=' -- see comment in pp_concat
3f872cb9 2665 return "concat";
9d2c6865 2666 }
3f872cb9
GS
2667 if ($name eq "null" and class($op) eq "UNOP"
2668 and $op->first->name =~ /^(and|x?or)$/
9d2c6865
SM
2669 and null $op->first->sibling)
2670 {
2671 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
2672 # with a null that's used as the common end point of the two
2673 # flows of control. For precedence purposes, ignore it.
2674 # (COND_EXPRs have these too, but we don't bother with
2675 # their associativity).
2676 return assoc_class($op->first);
2677 }
2678 return $name . ($op->flags & OPf_STACKED ? "=" : "");
2679}
2680
e38ccfd9 2681# Left associative operators, like '+', for which
9d2c6865
SM
2682# $a + $b + $c is equivalent to ($a + $b) + $c
2683
2684BEGIN {
3f872cb9
GS
2685 %left = ('multiply' => 19, 'i_multiply' => 19,
2686 'divide' => 19, 'i_divide' => 19,
2687 'modulo' => 19, 'i_modulo' => 19,
2688 'repeat' => 19,
2689 'add' => 18, 'i_add' => 18,
2690 'subtract' => 18, 'i_subtract' => 18,
2691 'concat' => 18,
2692 'left_shift' => 17, 'right_shift' => 17,
2693 'bit_and' => 13,
2694 'bit_or' => 12, 'bit_xor' => 12,
2695 'and' => 3,
2696 'or' => 2, 'xor' => 2,
9d2c6865
SM
2697 );
2698}
2699
2700sub deparse_binop_left {
2701 my $self = shift;
2702 my($op, $left, $prec) = @_;
58231d39 2703 if ($left{assoc_class($op)} && $left{assoc_class($left)}
9d2c6865
SM
2704 and $left{assoc_class($op)} == $left{assoc_class($left)})
2705 {
2706 return $self->deparse($left, $prec - .00001);
2707 } else {
2708 return $self->deparse($left, $prec);
2709 }
2710}
2711
e38ccfd9 2712# Right associative operators, like '=', for which
9d2c6865
SM
2713# $a = $b = $c is equivalent to $a = ($b = $c)
2714
2715BEGIN {
3f872cb9
GS
2716 %right = ('pow' => 22,
2717 'sassign=' => 7, 'aassign=' => 7,
2718 'multiply=' => 7, 'i_multiply=' => 7,
2719 'divide=' => 7, 'i_divide=' => 7,
2720 'modulo=' => 7, 'i_modulo=' => 7,
9187b6e4 2721 'repeat=' => 7, 'refassign' => 7, 'refassign=' => 7,
3f872cb9
GS
2722 'add=' => 7, 'i_add=' => 7,
2723 'subtract=' => 7, 'i_subtract=' => 7,
2724 'concat=' => 7,
2725 'left_shift=' => 7, 'right_shift=' => 7,
2726 'bit_and=' => 7,
2727 'bit_or=' => 7, 'bit_xor=' => 7,
2728 'andassign' => 7,
2729 'orassign' => 7,
9d2c6865
SM
2730 );
2731}
2732
2733sub deparse_binop_right {
2734 my $self = shift;
2735 my($op, $right, $prec) = @_;
58231d39 2736 if ($right{assoc_class($op)} && $right{assoc_class($right)}
9d2c6865
SM
2737 and $right{assoc_class($op)} == $right{assoc_class($right)})
2738 {
2739 return $self->deparse($right, $prec - .00001);
2740 } else {
2741 return $self->deparse($right, $prec);
2742 }
2743}
2744
a798dbf2 2745sub binop {
6e90668e 2746 my $self = shift;
9d2c6865 2747 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
a798dbf2
MB
2748 my $left = $op->first;
2749 my $right = $op->last;
9d2c6865
SM
2750 my $eq = "";
2751 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
2752 $eq = "=";
2753 $prec = 7;
2754 }
a798dbf2
MB
2755 if ($flags & SWAP_CHILDREN) {
2756 ($left, $right) = ($right, $left);
2757 }
6a861075 2758 my $leftop = $left;
9d2c6865 2759 $left = $self->deparse_binop_left($op, $left, $prec);
90c0eb26 2760 $left = "($left)" if $flags & LIST_CONTEXT
6a861075
FC
2761 and $left !~ /^(my|our|local|)[\@\(]/
2762 || do {
2763 # Parenthesize if the left argument is a
2764 # lone repeat op.
2765 my $left = $leftop->first->sibling;
2766 $left->name eq 'repeat'
2767 && null($left->sibling);
2768 };
9d2c6865
SM
2769 $right = $self->deparse_binop_right($op, $right, $prec);
2770 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
2771}
2772
3ed82cfc
GS
2773sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2774sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2775sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
2776sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2777sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2778sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2779sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2780sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
2781sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2782sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2783sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
2784
2785sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
2786sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
2787sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
2788sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
2789sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
9d2c6865
SM
2790
2791sub pp_eq { binop(@_, "==", 14) }
2792sub pp_ne { binop(@_, "!=", 14) }
2793sub pp_lt { binop(@_, "<", 15) }
2794sub pp_gt { binop(@_, ">", 15) }
2795sub pp_ge { binop(@_, ">=", 15) }
2796sub pp_le { binop(@_, "<=", 15) }
2797sub pp_ncmp { binop(@_, "<=>", 14) }
2798sub pp_i_eq { binop(@_, "==", 14) }
2799sub pp_i_ne { binop(@_, "!=", 14) }
2800sub pp_i_lt { binop(@_, "<", 15) }
2801sub pp_i_gt { binop(@_, ">", 15) }
2802sub pp_i_ge { binop(@_, ">=", 15) }
2803sub pp_i_le { binop(@_, "<=", 15) }
2804sub pp_i_ncmp { binop(@_, "<=>", 14) }
2805
2806sub pp_seq { binop(@_, "eq", 14) }
2807sub pp_sne { binop(@_, "ne", 14) }
2808sub pp_slt { binop(@_, "lt", 15) }
2809sub pp_sgt { binop(@_, "gt", 15) }
2810sub pp_sge { binop(@_, "ge", 15) }
2811sub pp_sle { binop(@_, "le", 15) }
2812sub pp_scmp { binop(@_, "cmp", 14) }
2813
2814sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
7013e6ae 2815sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
6e90668e 2816
0d863452
RH
2817sub pp_smartmatch {
2818 my ($self, $op, $cx) = @_;
2819 if ($op->flags & OPf_SPECIAL) {
9210de83 2820 return $self->deparse($op->last, $cx);
0d863452
RH
2821 }
2822 else {
2823 binop(@_, "~~", 14);
2824 }
2825}
2826
e38ccfd9 2827# '.' is special because concats-of-concats are optimized to save copying
6e90668e 2828# by making all but the first concat stacked. The effect is as if the
e38ccfd9 2829# programmer had written '($a . $b) .= $c', except legal.
3ed82cfc
GS
2830sub pp_concat { maybe_targmy(@_, \&real_concat) }
2831sub real_concat {
6e90668e 2832 my $self = shift;
9d2c6865 2833 my($op, $cx) = @_;
6e90668e
SM
2834 my $left = $op->first;
2835 my $right = $op->last;
2836 my $eq = "";
9d2c6865 2837 my $prec = 18;
3f872cb9 2838 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
6e90668e 2839 $eq = "=";
9d2c6865 2840 $prec = 7;
6e90668e 2841 }
9d2c6865
SM
2842 $left = $self->deparse_binop_left($op, $left, $prec);
2843 $right = $self->deparse_binop_right($op, $right, $prec);
2844 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
6e90668e
SM
2845}
2846
6402d4ee
FC
2847sub pp_repeat { maybe_targmy(@_, \&repeat) }
2848
e38ccfd9 2849# 'x' is weird when the left arg is a list
6402d4ee 2850sub repeat {
6e90668e 2851 my $self = shift;
9d2c6865 2852 my($op, $cx) = @_;
6e90668e
SM
2853 my $left = $op->first;
2854 my $right = $op->last;
9d2c6865
SM
2855 my $eq = "";
2856 my $prec = 19;
2857 if ($op->flags & OPf_STACKED) {
2858 $eq = "=";
2859 $prec = 7;
2860 }
6e90668e 2861 if (null($right)) { # list repeat; count is inside left-side ex-list
5e462669 2862 # in 5.21.5 and earlier
6e90668e
SM
2863 my $kid = $left->first->sibling; # skip pushmark
2864 my @exprs;
2865 for (; !null($kid->sibling); $kid = $kid->sibling) {
9d2c6865 2866 push @exprs, $self->deparse($kid, 6);
6e90668e
SM
2867 }
2868 $right = $kid;
2869 $left = "(" . join(", ", @exprs). ")";
2870 } else {
5e462669
FC
2871 my $dolist = $op->private & OPpREPEAT_DOLIST;
2872 $left = $self->deparse_binop_left($op, $left, $dolist ? 1 : $prec);
2873 if ($dolist) {
2874 $left = "($left)";
2875 }
6e90668e 2876 }
9d2c6865
SM
2877 $right = $self->deparse_binop_right($op, $right, $prec);
2878 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
6e90668e
SM
2879}
2880
2881sub range {
2882 my $self = shift;
9d2c6865 2883 my ($op, $cx, $type) = @_;
6e90668e
SM
2884 my $left = $op->first;
2885 my $right = $left->sibling;
9d2c6865
SM
2886 $left = $self->deparse($left, 9);
2887 $right = $self->deparse($right, 9);
2888 return $self->maybe_parens("$left $type $right", $cx, 9);
6e90668e
SM
2889}
2890
2891sub pp_flop {
2892 my $self = shift;
9d2c6865 2893 my($op, $cx) = @_;
6e90668e
SM
2894 my $flip = $op->first;
2895 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
9d2c6865 2896 return $self->range($flip->first, $cx, $type);
6e90668e
SM
2897}
2898
2899# one-line while/until is handled in pp_leave
2900
2901sub logop {
2902 my $self = shift;
9d2c6865 2903 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
6e90668e
SM
2904 my $left = $op->first;
2905 my $right = $op->first->sibling;
7741ceed 2906 $blockname &&= $self->keyword($blockname);
d989cdac 2907 if ($cx < 1 and is_scope($right) and $blockname
58cccf98
SM
2908 and $self->{'expand'} < 7)
2909 { # if ($a) {$b}
9d2c6865
SM
2910 $left = $self->deparse($left, 1);
2911 $right = $self->deparse($right, 0);
2912 return "$blockname ($left) {\n\t$right\n\b}\cK";
d989cdac 2913 } elsif ($cx < 1 and $blockname and not $self->{'parens'}
58cccf98 2914 and $self->{'expand'} < 7) { # $b if $a
9d2c6865
SM
2915 $right = $self->deparse($right, 1);
2916 $left = $self->deparse($left, 1);
2917 return "$right $blockname $left";
2918 } elsif ($cx > $lowprec and $highop) { # $a && $b
2919 $left = $self->deparse_binop_left($op, $left, $highprec);
2920 $right = $self->deparse_binop_right($op, $right, $highprec);
2921 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
2922 } else { # $a and $b
2923 $left = $self->deparse_binop_left($op, $left, $lowprec);
2924 $right = $self->deparse_binop_right($op, $right, $lowprec);
d989cdac 2925 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
9d2c6865
SM
2926 }
2927}
2928
2929sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
f4a44678 2930sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
5b99f273 2931sub pp_dor { logop(@_, "//", 10) }
3ed82cfc
GS
2932
2933# xor is syntactically a logop, but it's really a binop (contrary to
2934# old versions of opcode.pl). Syntax is what matters here.
9d2c6865 2935sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
6e90668e
SM
2936
2937sub logassignop {
2938 my $self = shift;
9d2c6865 2939 my ($op, $cx, $opname) = @_;
6e90668e
SM
2940 my $left = $op->first;
2941 my $right = $op->first->sibling->first; # skip sassign
9d2c6865
SM
2942 $left = $self->deparse($left, 7);
2943 $right = $self->deparse($right, 7);
2944 return $self->maybe_parens("$left $opname $right", $cx, 7);
a798dbf2
MB
2945}
2946
6e90668e 2947sub pp_andassign { logassignop(@_, "&&=") }
c963b151
BD
2948sub pp_orassign { logassignop(@_, "||=") }
2949sub pp_dorassign { logassignop(@_, "//=") }
6e90668e 2950
b89b7257
FC
2951sub rv2gv_or_string {
2952 my($self,$op) = @_;
2953 if ($op->name eq "gv") { # could be open("open") or open("###")
be6cf5cf 2954 my($name,$quoted) =
1db94eeb 2955 $self->stash_variable_name("", $self->gv_or_padgv($op));
be6cf5cf 2956 $quoted ? $name : "*$name";
b89b7257
FC
2957 }
2958 else {
2959 $self->deparse($op, 6);
2960 }
2961}
2962
6e90668e
SM
2963sub listop {
2964 my $self = shift;
9c56d9ea 2965 my($op, $cx, $name, $kid, $nollafr) = @_;
9d2c6865
SM
2966 my(@exprs);
2967 my $parens = ($cx >= 5) || $self->{'parens'};
24fcb59f 2968 $kid ||= $op->first->sibling;
4d8ac5c7
FC
2969 # If there are no arguments, add final parentheses (or parenthesize the
2970 # whole thing if the llafr does not apply) to account for cases like
2971 # (return)+1 or setpgrp()+1. When the llafr does not apply, we use a
2972 # precedence of 6 (< comma), as "return, 1" does not need parentheses.
2973 if (null $kid) {
2974 return $nollafr
2975 ? $self->maybe_parens($self->keyword($name), $cx, 7)
2976 : $self->keyword($name) . '()' x (7 < $cx);
2977 }
e31885a0 2978 my $first;
4a1ac32e 2979 my $fullname = $self->keyword($name);
b72c97e8 2980 my $proto = prototype("CORE::$name");
bc1cc2c3
DM
2981 if (
2982 ( (defined $proto && $proto =~ /^;?\*/)
2983 || $name eq 'select' # select(F) doesn't have a proto
2984 )
2985 && $kid->name eq "rv2gv"
2986 && !($kid->private & OPpLVAL_INTRO)
2987 ) {
b89b7257 2988 $first = $self->rv2gv_or_string($kid->first);
e31885a0
RH
2989 }
2990 else {
2991 $first = $self->deparse($kid, 6);
2992 }
e99ebc55 2993 if ($name eq "chmod" && $first =~ /^\d+$/) {
a0035eb8 2994 $first = sprintf("%#o", $first);
e99ebc55 2995 }
9c56d9ea
FC
2996 $first = "+$first"
2997 if not $parens and not $nollafr and substr($first, 0, 1) eq "(";
9d2c6865
SM
2998 push @exprs, $first;
2999 $kid = $kid->sibling;
564cd6cb
FC
3000 if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv"
3001 && !($kid->private & OPpLVAL_INTRO)) {
b89b7257 3002 push @exprs, $first = $self->rv2gv_or_string($kid->first);
b72c97e8
RGS
3003 $kid = $kid->sibling;
3004 }
9d2c6865
SM
3005 for (; !null($kid); $kid = $kid->sibling) {
3006 push @exprs, $self->deparse($kid, 6);
3007 }
689e417f 3008 if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) {
4a1ac32e
FC
3009 return "$exprs[0] = $fullname"
3010 . ($parens ? "($exprs[0])" : " $exprs[0]");
689e417f 3011 }
327088eb 3012
9c56d9ea
FC
3013 if ($parens && $nollafr) {
3014 return "($fullname " . join(", ", @exprs) . ")";
3015 } elsif ($parens) {
4a1ac32e 3016 return "$fullname(" . join(", ", @exprs) . ")";
9d2c6865 3017 } else {
4a1ac32e 3018 return "$fullname " . join(", ", @exprs);
6e90668e 3019 }
6e90668e 3020}
a798dbf2 3021
6e90668e 3022sub pp_bless { listop(@_, "bless") }
3ed82cfc 3023sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
24fcb59f
FC
3024sub pp_substr {
3025 my ($self,$op,$cx) = @_;
3026 if ($op->private & OPpSUBSTR_REPL_FIRST) {
3027 return
3028 listop($self, $op, 7, "substr", $op->first->sibling->sibling)
3029 . " = "
3030 . $self->deparse($op->first->sibling, 7);
3031 }
3032 maybe_local(@_, listop(@_, "substr"))
3033}
6402d4ee 3034sub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) }
3ed82cfc
GS
3035sub pp_index { maybe_targmy(@_, \&listop, "index") }
3036sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
3037sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
6e90668e 3038sub pp_formline { listop(@_, "formline") } # see also deparse_format
3ed82cfc 3039sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
6e90668e
SM
3040sub pp_unpack { listop(@_, "unpack") }
3041sub pp_pack { listop(@_, "pack") }
3ed82cfc 3042sub pp_join { maybe_targmy(@_, \&listop, "join") }
6e90668e 3043sub pp_splice { listop(@_, "splice") }
3ed82cfc
GS
3044sub pp_push { maybe_targmy(@_, \&listop, "push") }
3045sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
6e90668e
SM
3046sub pp_reverse { listop(@_, "reverse") }
3047sub pp_warn { listop(@_, "warn") }
3048sub pp_die { listop(@_, "die") }
9c56d9ea 3049sub pp_return { listop(@_, "return", undef, 1) } # llafr does not apply
6e90668e
SM
3050sub pp_open { listop(@_, "open") }
3051sub pp_pipe_op { listop(@_, "pipe") }
3052sub pp_tie { listop(@_, "tie") }
82bafd27 3053sub pp_binmode { listop(@_, "binmode") }
6e90668e
SM
3054sub pp_dbmopen { listop(@_, "dbmopen") }
3055sub pp_sselect { listop(@_, "select") }
3056sub pp_select { listop(@_, "select") }
3057sub pp_read { listop(@_, "read") }
3058sub pp_sysopen { listop(@_, "sysopen") }
3059sub pp_sysseek { listop(@_, "sysseek") }
3060sub pp_sysread { listop(@_, "sysread") }
3061sub pp_syswrite { listop(@_, "syswrite") }
3062sub pp_send { listop(@_, "send") }
3063sub pp_recv { listop(@_, "recv") }
3064sub pp_seek { listop(@_, "seek") }
6e90668e
SM
3065sub pp_fcntl { listop(@_, "fcntl") }
3066sub pp_ioctl { listop(@_, "ioctl") }
3ed82cfc 3067sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
6e90668e 3068sub pp_socket { listop(@_, "socket") }
5deb1341 3069sub pp_sockpair { listop(@_, "socketpair") }
6e90668e
SM
3070sub pp_bind { listop(@_, "bind") }
3071sub pp_connect { listop(@_, "connect") }
3072sub pp_listen { listop(@_, "listen") }
3073sub pp_accept { listop(@_, "accept") }
3074sub pp_shutdown { listop(@_, "shutdown") }
3075sub pp_gsockopt { listop(@_, "getsockopt") }
3076sub pp_ssockopt { listop(@_, "setsockopt") }
3ed82cfc
GS
3077sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
3078sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
3079sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
3080sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
3081sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
3082sub pp_link { maybe_targmy(@_, \&listop, "link") }
3083sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
3084sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
6e90668e
SM
3085sub pp_open_dir { listop(@_, "opendir") }
3086sub pp_seekdir { listop(@_, "seekdir") }
3ed82cfc 3087sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
9d52f6f3
FC
3088sub pp_system { maybe_targmy(@_, \&indirop, "system") }
3089sub pp_exec { maybe_targmy(@_, \&indirop, "exec") }
3ed82cfc
GS
3090sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
3091sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
3092sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
3093sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
6e90668e
SM
3094sub pp_shmget { listop(@_, "shmget") }
3095sub pp_shmctl { listop(@_, "shmctl") }
3096sub pp_shmread { listop(@_, "shmread") }
3097sub pp_shmwrite { listop(@_, "shmwrite") }
3098sub pp_msgget { listop(@_, "msgget") }
3099sub pp_msgctl { listop(@_, "msgctl") }
3100sub pp_msgsnd { listop(@_, "msgsnd") }
3101sub pp_msgrcv { listop(@_, "msgrcv") }
3102sub pp_semget { listop(@_, "semget") }
3103sub pp_semctl { listop(@_, "semctl") }
3104sub pp_semop { listop(@_, "semop") }
3105sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
3106sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
3107sub pp_gpbynumber { listop(@_, "getprotobynumber") }
3108sub pp_gsbyname { listop(@_, "getservbyname") }
3109sub pp_gsbyport { listop(@_, "getservbyport") }
3110sub pp_syscall { listop(@_, "syscall") }
3111
3112sub pp_glob {
3113 my $self = shift;
9d2c6865 3114 my($op, $cx) = @_;
93860275 3115 my $kid = $op->first->sibling; # skip pushmark
a32fbbd8
FC
3116 my $keyword =
3117 $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
93860275
FC
3118 my $text;
3119 if ($keyword =~ /^CORE::/
3120 or $kid->name ne 'const'
3121 or ($text = $self->dq($kid))
3122 =~ /^\$?(\w|::|\`)+$/ # could look like a readline
a32fbbd8 3123 or $text =~ /[<>]/) {
93860275
FC
3124 $text = $self->deparse($kid);
3125 return $cx >= 5 || $self->{'parens'}
3126 ? "$keyword($text)"
3127 : "$keyword $text";
6e90668e
SM
3128 } else {
3129 return '<' . $text . '>';
3130 }
3131}
3132
f5aa8f4e
SM
3133# Truncate is special because OPf_SPECIAL makes a bareword first arg
3134# be a filehandle. This could probably be better fixed in the core
3135# by moving the GV lookup into ck_truc.
3136
3137sub pp_truncate {
3138 my $self = shift;
3139 my($op, $cx) = @_;
3140 my(@exprs);
3141 my $parens = ($cx >= 5) || $self->{'parens'};
3142 my $kid = $op->first->sibling;
acba1d67 3143 my $fh;
f5aa8f4e
SM
3144 if ($op->flags & OPf_SPECIAL) {
3145 # $kid is an OP_CONST
18228111 3146 $fh = $self->const_sv($kid)->PV;
f5aa8f4e
SM
3147 } else {
3148 $fh = $self->deparse($kid, 6);
3149 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
3150 }
3151 my $len = $self->deparse($kid->sibling, 6);
4a1ac32e 3152 my $name = $self->keyword('truncate');
f5aa8f4e 3153 if ($parens) {
4a1ac32e 3154 return "$name($fh, $len)";
f5aa8f4e 3155 } else {
4a1ac32e 3156 return "$name $fh, $len";
f5aa8f4e 3157 }
f5aa8f4e
SM
3158}
3159
6e90668e
SM
3160sub indirop {
3161 my $self = shift;
9d2c6865 3162 my($op, $cx, $name) = @_;
6e90668e 3163 my($expr, @exprs);
521795fe 3164 my $firstkid = my $kid = $op->first->sibling;
6e90668e
SM
3165 my $indir = "";
3166 if ($op->flags & OPf_STACKED) {
3167 $indir = $kid;
3168 $indir = $indir->first; # skip rv2gv
3169 if (is_scope($indir)) {
9d2c6865 3170 $indir = "{" . $self->deparse($indir, 0) . "}";
d989cdac 3171 $indir = "{;}" if $indir eq "{}";
c73811ab
RH
3172 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
3173 $indir = $self->const_sv($indir)->PV;
6e90668e 3174 } else {
9d2c6865 3175 $indir = $self->deparse($indir, 24);
6e90668e
SM
3176 }
3177 $indir = $indir . " ";
3178 $kid = $kid->sibling;
3179 }
7e80da18 3180 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
3ac6e0f9 3181 $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
7e80da18
RH
3182 : '{$a <=> $b} ';
3183 }
3ac6e0f9 3184 elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
7e80da18
RH
3185 $indir = '{$b cmp $a} ';
3186 }
6e90668e 3187 for (; !null($kid); $kid = $kid->sibling) {
521795fe 3188 $expr = $self->deparse($kid, !$indir && $kid == $firstkid && $name eq "sort" && $firstkid->name eq "entersub" ? 16 : 6);
6e90668e
SM
3189 push @exprs, $expr;
3190 }
4a1ac32e 3191 my $name2;
3ac6e0f9 3192 if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
4a1ac32e 3193 $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort');
3ac6e0f9 3194 }
4a1ac32e 3195 else { $name2 = $self->keyword($name) }
2b6e98cb 3196 if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
3ac6e0f9 3197 return "$exprs[0] = $name2 $indir $exprs[0]";
2b6e98cb
DM
3198 }
3199
d989cdac 3200 my $args = $indir . join(", ", @exprs);
521795fe 3201 if ($indir ne "" && $name eq "sort") {
d989cdac
SM
3202 # We don't want to say "sort(f 1, 2, 3)", since perl -w will
3203 # give bareword warnings in that case. Therefore if context
3204 # requires, we'll put parens around the outside "(sort f 1, 2,
3205 # 3)". Unfortunately, we'll currently think the parens are
3c4b39be 3206 # necessary more often that they really are, because we don't
d989cdac
SM
3207 # distinguish which side of an assignment we're on.
3208 if ($cx >= 5) {
3ac6e0f9 3209 return "($name2 $args)";
d989cdac 3210 } else {
3ac6e0f9 3211 return "$name2 $args";
d989cdac 3212 }
521795fe
FC
3213 } elsif (
3214 !$indir && $name eq "sort"
ca331985 3215 && !null($op->first->sibling)
521795fe
FC
3216 && $op->first->sibling->name eq 'entersub'
3217 ) {
3218 # We cannot say sort foo(bar), as foo will be interpreted as a
3219 # comparison routine. We have to say sort(...) in that case.
3220 return "$name2($args)";
d989cdac 3221 } else {
9d52f6f3
FC
3222 return length $args
3223 ? $self->maybe_parens_func($name2, $args, $cx, 5)
3224 : $name2 . '()' x (7 < $cx);
d989cdac
SM
3225 }
3226
6e90668e
SM
3227}
3228
3229sub pp_prtf { indirop(@_, "printf") }
3230sub pp_print { indirop(@_, "print") }
9b08e3d3 3231sub pp_say { indirop(@_, "say") }
6e90668e
SM
3232sub pp_sort { indirop(@_, "sort") }
3233
3234sub mapop {
3235 my $self = shift;
9d2c6865 3236 my($op, $cx, $name) = @_;
6e90668e
SM
3237 my($expr, @exprs);
3238 my $kid = $op->first; # this is the (map|grep)start
3239 $kid = $kid->first->sibling; # skip a pushmark
3240 my $code = $kid->first; # skip a null
3241 if (is_scope $code) {
f4a44678 3242 $code = "{" . $self->deparse($code, 0) . "} ";
6e90668e 3243 } else {
6d08f7b3
DM
3244 $code = $self->deparse($code, 24);
3245 $code .= ", " if !null($kid->sibling);
6e90668e
SM
3246 }
3247 $kid = $kid->sibling;
3248 for (; !null($kid); $kid = $kid->sibling) {
9d2c6865 3249 $expr = $self->deparse($kid, 6);
9a58b761 3250 push @exprs, $expr if defined $expr;
6e90668e 3251 }
3188a821
FC
3252 return $self->maybe_parens_func($self->keyword($name),
3253 $code . join(", ", @exprs), $cx, 5);
6e90668e
SM
3254}
3255
d989cdac
SM
3256sub pp_mapwhile { mapop(@_, "map") }
3257sub pp_grepwhile { mapop(@_, "grep") }
11e09183
SP
3258sub pp_mapstart { baseop(@_, "map") }
3259sub pp_grepstart { baseop(@_, "grep") }
6e90668e 3260
12cea2fa
FC
3261my %uses_intro;
3262BEGIN {
3263 @uses_intro{
3264 eval { require B::Op_private }
e58dedd3 3265 ? @{$B::Op_private::ops_using{OPpLVAL_INTRO}}
12cea2fa
FC
3266 : qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice
3267 hslice delete padsv padav padhv enteriter entersub padrange
3268 pushmark cond_expr refassign list)
3269 } = ();
bba4f5ff 3270 delete @uses_intro{qw( lvref lvrefslice lvavref entersub )};
12cea2fa
FC
3271}
3272
6e90668e
SM
3273sub pp_list {
3274 my $self = shift;
9d2c6865 3275 my($op, $cx) = @_;
6e90668e
SM
3276 my($expr, @exprs);
3277 my $kid = $op->first->sibling; # skip pushmark
958ed56b 3278 return '' if class($kid) eq 'NULL';
6e90668e 3279 my $lop;
3462b4ac 3280 my $local = "either"; # could be local(...), my(...), state(...) or our(...)
56cd2ef8 3281 my $type;
6e90668e 3282 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
3b4e80b8 3283 my $lopname = $lop->name;
5f4d8496 3284 my $loppriv = $lop->private;
56cd2ef8 3285 my $newtype;
12cea2fa 3286 if ($lopname =~ /^pad[ash]v$/ && $loppriv & OPpLVAL_INTRO) {
5f4d8496
FC
3287 if ($loppriv & OPpPAD_STATE) { # state()
3288 ($local = "", last) if $local !~ /^(?:either|state)$/;
3462b4ac
RGS
3289 $local = "state";
3290 } else { # my()
5f4d8496 3291 ($local = "", last) if $local !~ /^(?:either|my)$/;
3462b4ac
RGS
3292 $local = "my";
3293 }
56cd2ef8
FC
3294 my $padname = $self->padname_sv($lop->targ);
3295 if ($padname->FLAGS & SVpad_TYPED) {
3296 $newtype = $padname->SvSTASH->NAME;
3297 }
3b4e80b8 3298 } elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/
5f4d8496 3299 && $loppriv & OPpOUR_INTRO
40ced2f4
FC
3300 or $lopname eq "null" && class($lop) eq 'UNOP'
3301 && $lop->first->name eq "gvsv"
b8e103fc 3302 && $lop->first->private & OPpOUR_INTRO) { # our()
5f4d8496
FC
3303 my $newlocal = "local " x !!($loppriv & OPpLVAL_INTRO) . "our";
3304 ($local = "", last)
3305 if $local ne 'either' && $local ne $newlocal;
3306 $local = $newlocal;
56cd2ef8
FC
3307 my $funny = !$1 || $1 eq 's' ? '$' : $1 eq 'a' ? '@' : '%';
3308 if (my $t = $self->find_our_type(
3309 $funny . $self->gv_or_padgv($lop->first)->NAME
3310 )) {
3311 $newtype = $t;
3312 }
12cea2fa
FC
3313 } elsif ($lopname ne 'undef'
3314 and !($loppriv & OPpLVAL_INTRO)
3315 || !exists $uses_intro{$lopname eq 'null'
3316 ? substr B::ppname($lop->targ), 3
3317 : $lopname})
3318 {
3319 $local = ""; # or not
3320 last;
3321 } elsif ($lopname ne "undef")
3ac6e0f9
RGS
3322 {
3323 # local()
5f4d8496 3324 ($local = "", last) if $local !~ /^(?:either|local)$/;
6e90668e
SM
3325 $local = "local";
3326 }
56cd2ef8
FC
3327 if (defined $type && defined $newtype && $newtype ne $type) {
3328 $local = '';
3329 last;
3330 }
3331 $type = $newtype;
6e90668e
SM
3332 }
3333 $local = "" if $local eq "either"; # no point if it's all undefs
5f4d8496 3334 $local &&= join ' ', map $self->keyword($_), split / /, $local;
56cd2ef8 3335 $local .= " $type " if $local && length $type;
f5aa8f4e 3336 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
6e90668e
SM
3337 for (; !null($kid); $kid = $kid->sibling) {
3338 if ($local) {
3f872cb9 3339 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
6e90668e
SM
3340 $lop = $kid->first;
3341 } else {
3342 $lop = $kid;
3343 }
3344 $self->{'avoid_local'}{$$lop}++;
9d2c6865 3345 $expr = $self->deparse($kid, 6);
6e90668e
SM
3346 delete $self->{'avoid_local'}{$$lop};
3347 } else {
9d2c6865 3348 $expr = $self->deparse($kid, 6);
6e90668e
SM
3349 }
3350 push @exprs, $expr;
3351 }
9d2c6865
SM
3352 if ($local) {
3353 return "$local(" . join(", ", @exprs) . ")";
3354 } else {
3355 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
3356 }
6e90668e
SM
3357}
3358
6f611a1a
GS
3359sub is_ifelse_cont {
3360 my $op = shift;
3361 return ($op->name eq "null" and class($op) eq "UNOP"
3362 and $op->first->name =~ /^(and|cond_expr)$/
3363 and is_scope($op->first->first->sibling));
3364}
3365
6e90668e
SM
3366sub pp_cond_expr {
3367 my $self = shift;
9d2c6865 3368 my($op, $cx) = @_;
6e90668e
SM
3369 my $cond = $op->first;
3370 my $true = $cond->sibling;
3371 my $false = $true->sibling;
9d2c6865 3372 my $cuddle = $self->{'cuddle'};
d989cdac 3373 unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
58cccf98
SM
3374 (is_scope($false) || is_ifelse_cont($false))
3375 and $self->{'expand'} < 7) {
f5aa8f4e 3376 $cond = $self->deparse($cond, 8);
cfaba469 3377 $true = $self->deparse($true, 6);
9d2c6865
SM
3378 $false = $self->deparse($false, 8);
3379 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
6f611a1a
GS
3380 }
3381
f5aa8f4e 3382 $cond = $self->deparse($cond, 1);
d989cdac 3383 $true = $self->deparse($true, 0);
7741ceed 3384 my $head = $self->keyword("if") . " ($cond) {\n\t$true\n\b}";
6f611a1a 3385 my @elsifs;
7741ceed 3386 my $elsif;
6f611a1a
GS
3387 while (!null($false) and is_ifelse_cont($false)) {
3388 my $newop = $false->first;
3389 my $newcond = $newop->first;
3390 my $newtrue = $newcond->sibling;
3391 $false = $newtrue->sibling; # last in chain is OP_AND => no else
7ecdd211
PJ
3392 if ($newcond->name eq "lineseq")
3393 {
3394 # lineseq to ensure correct line numbers in elsif()
3395 # Bug #37302 fixed by change #33710.
3396 $newcond = $newcond->first->sibling;
3397 }
6f611a1a
GS
3398 $newcond = $self->deparse($newcond, 1);
3399 $newtrue = $self->deparse($newtrue, 0);
7741ceed
FC
3400 $elsif ||= $self->keyword("elsif");
3401 push @elsifs, "$elsif ($newcond) {\n\t$newtrue\n\b}";
6f611a1a 3402 }
d989cdac 3403 if (!null($false)) {
7741ceed 3404 $false = $cuddle . $self->keyword("else") . " {\n\t" .
6f611a1a
GS
3405 $self->deparse($false, 0) . "\n\b}\cK";
3406 } else {
3407 $false = "\cK";
6e90668e 3408 }
d989cdac 3409 return $head . join($cuddle, "", @elsifs) . $false;
6e90668e
SM
3410}
3411
95562366
NC
3412sub pp_once {
3413 my ($self, $op, $cx) = @_;
3414 my $cond = $op->first;
3415 my $true = $cond->sibling;
3416
a1b22abd
FC
3417 my $ret = $self->deparse($true, $cx);
3418 $ret =~ s/^(\(?)\$/$1 . $self->keyword("state") . ' $'/e;
3419 $ret;
95562366
NC
3420}
3421
58cccf98 3422sub loop_common {
6e90668e 3423 my $self = shift;
58cccf98 3424 my($op, $cx, $init) = @_;
6e90668e
SM
3425 my $enter = $op->first;
3426 my $kid = $enter->sibling;
0ced6c29
RGS
3427 local(@$self{qw'curstash warnings hints hinthash'})
3428 = @$self{qw'curstash warnings hints hinthash'};
6e90668e 3429 my $head = "";
9d2c6865 3430 my $bare = 0;
58cccf98
SM
3431 my $body;
3432 my $cond = undef;
22584011 3433 my $name;
d989cdac 3434 if ($kid->name eq "lineseq") { # bare or infinite loop
241416b8 3435 if ($kid->last->name eq "unstack") { # infinite
e99ebc55 3436 $head = "while (1) "; # Can't use for(;;) if there's a continue
58cccf98 3437 $cond = "";
9d2c6865
SM
3438 } else {
3439 $bare = 1;
6e90668e 3440 }
58cccf98 3441 $body = $kid;