This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix up exists etc deparsing
[perl5.git] / lib / B / Deparse.pm
1 # B::Deparse.pm
2 # Copyright (c) 1998-2000, 2002, 2003, 2004, 2005, 2006 Stephen McCamant.
3 # All rights reserved.
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
10 package B::Deparse;
11 use Carp;
12 use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
13          OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
14          OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPf_PARENS
15          OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
16          OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
17          OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST
18          OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE
19          SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
20          SVs_PADTMP SVpad_TYPED
21          CVf_METHOD CVf_LVALUE
22          PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
23          PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED PMf_EXTENDED_MORE
24          PADNAMEt_OUTER
25         MDEREF_reload
26         MDEREF_AV_pop_rv2av_aelem
27         MDEREF_AV_gvsv_vivify_rv2av_aelem
28         MDEREF_AV_padsv_vivify_rv2av_aelem
29         MDEREF_AV_vivify_rv2av_aelem
30         MDEREF_AV_padav_aelem
31         MDEREF_AV_gvav_aelem
32         MDEREF_HV_pop_rv2hv_helem
33         MDEREF_HV_gvsv_vivify_rv2hv_helem
34         MDEREF_HV_padsv_vivify_rv2hv_helem
35         MDEREF_HV_vivify_rv2hv_helem
36         MDEREF_HV_padhv_helem
37         MDEREF_HV_gvhv_helem
38         MDEREF_ACTION_MASK
39         MDEREF_INDEX_none
40         MDEREF_INDEX_const
41         MDEREF_INDEX_padsv
42         MDEREF_INDEX_gvsv
43         MDEREF_INDEX_MASK
44         MDEREF_FLAG_last
45         MDEREF_MASK
46         MDEREF_SHIFT
47     );
48
49 $VERSION = '1.38';
50 use strict;
51 use vars qw/$AUTOLOAD/;
52 use warnings ();
53 require feature;
54
55 BEGIN {
56     # List version-specific constants here.
57     # Easiest way to keep this code portable between version looks to
58     # be to fake up a dummy constant that will never actually be true.
59     foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
60                 OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE
61                 PMf_CHARSET PMf_KEEPCOPY PMf_NOCAPTURE CVf_ANONCONST
62                 CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
63                 PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES
64                 OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV
65                 OPpLVREF_CV OPpLVREF_ELEM SVpad_STATE)) {
66         eval { B->import($_) };
67         no strict 'refs';
68         *{$_} = sub () {0} unless *{$_}{CODE};
69     }
70 }
71
72 # Changes between 0.50 and 0.51:
73 # - fixed nulled leave with live enter in sort { }
74 # - fixed reference constants (\"str")
75 # - handle empty programs gracefully
76 # - handle infinite loops (for (;;) {}, while (1) {})
77 # - differentiate between 'for my $x ...' and 'my $x; for $x ...'
78 # - various minor cleanups
79 # - moved globals into an object
80 # - added '-u', like B::C
81 # - package declarations using cop_stash
82 # - subs, formats and code sorted by cop_seq
83 # Changes between 0.51 and 0.52:
84 # - added pp_threadsv (special variables under USE_5005THREADS)
85 # - added documentation
86 # Changes between 0.52 and 0.53:
87 # - many changes adding precedence contexts and associativity
88 # - added '-p' and '-s' output style options
89 # - various other minor fixes
90 # Changes between 0.53 and 0.54:
91 # - added support for new 'for (1..100)' optimization,
92 #   thanks to Gisle Aas
93 # Changes between 0.54 and 0.55:
94 # - added support for new qr// construct
95 # - added support for new pp_regcreset OP
96 # Changes between 0.55 and 0.56:
97 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
98 # - fixed $# on non-lexicals broken in last big rewrite
99 # - added temporary fix for change in opcode of OP_STRINGIFY
100 # - fixed problem in 0.54's for() patch in 'for (@ary)'
101 # - fixed precedence in conditional of ?:
102 # - tweaked list paren elimination in 'my($x) = @_'
103 # - made continue-block detection trickier wrt. null ops
104 # - fixed various prototype problems in pp_entersub
105 # - added support for sub prototypes that never get GVs
106 # - added unquoting for special filehandle first arg in truncate
107 # - print doubled rv2gv (a bug) as '*{*GV}' instead of illegal '**GV'
108 # - added semicolons at the ends of blocks
109 # - added -l '#line' declaration option -- fixes cmd/subval.t 27,28
110 # Changes between 0.56 and 0.561:
111 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
112 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
113 # Changes between 0.561 and 0.57:
114 # - stylistic changes to symbolic constant stuff
115 # - handled scope in s///e replacement code
116 # - added unquote option for expanding "" into concats, etc.
117 # - split method and proto parts of pp_entersub into separate functions
118 # - various minor cleanups
119 # Changes after 0.57:
120 # - added parens in \&foo (patch by Albert Dvornik)
121 # Changes between 0.57 and 0.58:
122 # - fixed '0' statements that weren't being printed
123 # - added methods for use from other programs
124 #   (based on patches from James Duncan and Hugo van der Sanden)
125 # - added -si and -sT to control indenting (also based on a patch from Hugo)
126 # - added -sv to print something else instead of '???'
127 # - preliminary version of utf8 tr/// handling
128 # Changes after 0.58:
129 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
130 # - added support for Hugo's new OP_SETSTATE (like nextstate)
131 # Changes between 0.58 and 0.59
132 # - added support for Chip's OP_METHOD_NAMED
133 # - added support for Ilya's OPpTARGET_MY optimization
134 # - elided arrows before '()' subscripts when possible
135 # Changes between 0.59 and 0.60
136 # - support for method attributes was added
137 # - some warnings fixed
138 # - separate recognition of constant subs
139 # - rewrote continue block handling, now recognizing for loops
140 # - added more control of expanding control structures
141 # Changes between 0.60 and 0.61 (mostly by Robin Houston)
142 # - many bug-fixes
143 # - support for pragmas and 'use'
144 # - support for the little-used $[ variable
145 # - support for __DATA__ sections
146 # - UTF8 support
147 # - BEGIN, CHECK, INIT and END blocks
148 # - scoping of subroutine declarations fixed
149 # - compile-time output from the input program can be suppressed, so that the
150 #   output is just the deparsed code. (a change to O.pm in fact)
151 # - our() declarations
152 # - *all* the known bugs are now listed in the BUGS section
153 # - comprehensive test mechanism (TEST -deparse)
154 # Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
155 # - bug-fixes
156 # - new switch -P
157 # - support for command-line switches (-l, -0, etc.)
158 # Changes between 0.63 and 0.64
159 # - support for //, CHECK blocks, and assertions
160 # - improved handling of foreach loops and lexicals
161 # - option to use Data::Dumper for constants
162 # - more bug fixes
163 # - discovered lots more bugs not yet fixed
164 #
165 # ...
166 #
167 # Changes between 0.72 and 0.73
168 # - support new switch constructs
169
170 # Todo:
171 #  (See also BUGS section at the end of this file)
172 #
173 # - finish tr/// changes
174 # - add option for even more parens (generalize \&foo change)
175 # - left/right context
176 # - copy comments (look at real text with $^P?)
177 # - avoid semis in one-statement blocks
178 # - associativity of &&=, ||=, ?:
179 # - ',' => '=>' (auto-unquote?)
180 # - break long lines ("\r" as discretionary break?)
181 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
182 # - more style options: brace style, hex vs. octal, quotes, ...
183 # - print big ints as hex/octal instead of decimal (heuristic?)
184 # - handle 'my $x if 0'?
185 # - version using op_next instead of op_first/sibling?
186 # - avoid string copies (pass arrays, one big join?)
187 # - here-docs?
188
189 # Current test.deparse failures
190 # comp/hints 6 - location of BEGIN blocks wrt. block openings
191 # run/switchI 1 - missing -I switches entirely
192 #    perl -Ifoo -e 'print @INC'
193 # op/caller 2 - warning mask propagates backwards before warnings::register
194 #    'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
195 # op/getpid 2 - can't assign to shared my() declaration (threads only)
196 #    'my $x : shared = 5'
197 # op/override 7 - parens on overridden require change v-string interpretation
198 #    'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
199 #    c.f. 'BEGIN { *f = sub {0} }; f 2'
200 # op/pat 774 - losing Unicode-ness of Latin1-only strings
201 #    'use charnames ":short"; $x="\N{latin:a with acute}"'
202 # op/recurse 12 - missing parens on recursive call makes it look like method
203 #    'sub f { f($x) }'
204 # op/subst 90 - inconsistent handling of utf8 under "use utf8"
205 # op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
206 # op/tiehandle compile - "use strict" deparsed in the wrong place
207 # uni/tr_ several
208 # ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
209 # ext/Data/Dumper/t/dumper compile
210 # ext/DB_file/several
211 # ext/Encode/several
212 # ext/Ernno/Errno warnings
213 # ext/IO/lib/IO/t/io_sel 23
214 # ext/PerlIO/t/encoding compile
215 # ext/POSIX/t/posix 6
216 # ext/Socket/Socket 8
217 # ext/Storable/t/croak compile
218 # lib/Attribute/Handlers/t/multi compile
219 # lib/bignum/ several
220 # lib/charnames 35
221 # lib/constant 32
222 # lib/English 40
223 # lib/ExtUtils/t/bytes 4
224 # lib/File/DosGlob compile
225 # lib/Filter/Simple/t/data 1
226 # lib/Math/BigInt/t/constant 1
227 # lib/Net/t/config Deparse-warning
228 # lib/overload compile
229 # lib/Switch/ several
230 # lib/Symbol 4
231 # lib/Test/Simple several
232 # lib/Term/Complete
233 # lib/Tie/File/t/29_downcopy 5
234 # lib/vars 22
235
236 # Object fields:
237 #
238 # in_coderef2text:
239 # True when deparsing via $deparse->coderef2text; false when deparsing the
240 # main program.
241 #
242 # avoid_local:
243 # (local($a), local($b)) and local($a, $b) have the same internal
244 # representation but the short form looks better. We notice we can
245 # use a large-scale local when checking the list, but need to prevent
246 # individual locals too. This hash holds the addresses of OPs that
247 # have already had their local-ness accounted for. The same thing
248 # is done with my().
249 #
250 # curcv:
251 # CV for current sub (or main program) being deparsed
252 #
253 # curcvlex:
254 # Cached hash of lexical variables for curcv: keys are
255 # names prefixed with "m" or "o" (representing my/our), and
256 # each value is an array with two elements indicating the cop_seq
257 # of scopes in which a var of that name is valid and a third ele-
258 # ment referencing the pad name.
259 #
260 # curcop:
261 # COP for statement being deparsed
262 #
263 # curstash:
264 # name of the current package for deparsed code
265 #
266 # subs_todo:
267 # array of [cop_seq, CV, is_format?, name] for subs and formats we still
268 # want to deparse.  The fourth element is a pad name thingy for lexical
269 # subs or a string for special blocks.  For other subs, it is undef.  For
270 # lexical subs, CV may be undef, indicating a stub declaration.
271 #
272 # protos_todo:
273 # as above, but [name, prototype] for subs that never got a GV
274 #
275 # subs_done, forms_done:
276 # keys are addresses of GVs for subs and formats we've already
277 # deparsed (or at least put into subs_todo)
278 #
279 # subs_declared
280 # keys are names of subs for which we've printed declarations.
281 # That means we can omit parentheses from the arguments. It also means we
282 # need to put CORE:: on core functions of the same name.
283 #
284 # in_subst_repl
285 # True when deparsing the replacement part of a substitution.
286 #
287 # in_refgen
288 # True when deparsing the argument to \.
289 #
290 # parens: -p
291 # linenums: -l
292 # unquote: -q
293 # cuddle: ' ' or '\n', depending on -sC
294 # indent_size: -si
295 # use_tabs: -sT
296 # ex_const: -sv
297
298 # A little explanation of how precedence contexts and associativity
299 # work:
300 #
301 # deparse() calls each per-op subroutine with an argument $cx (short
302 # for context, but not the same as the cx* in the perl core), which is
303 # a number describing the op's parents in terms of precedence, whether
304 # they're inside an expression or at statement level, etc.  (see
305 # chart below). When ops with children call deparse on them, they pass
306 # along their precedence. Fractional values are used to implement
307 # associativity ('($x + $y) + $z' => '$x + $y + $y') and related
308 # parentheses hacks. The major disadvantage of this scheme is that
309 # it doesn't know about right sides and left sides, so say if you
310 # assign a listop to a variable, it can't tell it's allowed to leave
311 # the parens off the listop.
312
313 # Precedences:
314 # 26             [TODO] inside interpolation context ("")
315 # 25 left        terms and list operators (leftward)
316 # 24 left        ->
317 # 23 nonassoc    ++ --
318 # 22 right       **
319 # 21 right       ! ~ \ and unary + and -
320 # 20 left        =~ !~
321 # 19 left        * / % x
322 # 18 left        + - .
323 # 17 left        << >>
324 # 16 nonassoc    named unary operators
325 # 15 nonassoc    < > <= >= lt gt le ge
326 # 14 nonassoc    == != <=> eq ne cmp
327 # 13 left        &
328 # 12 left        | ^
329 # 11 left        &&
330 # 10 left        ||
331 #  9 nonassoc    ..  ...
332 #  8 right       ?:
333 #  7 right       = += -= *= etc.
334 #  6 left        , =>
335 #  5 nonassoc    list operators (rightward)
336 #  4 right       not
337 #  3 left        and
338 #  2 left        or xor
339 #  1             statement modifiers
340 #  0.5           statements, but still print scopes as do { ... }
341 #  0             statement level
342 # -1             format body
343
344 # Nonprinting characters with special meaning:
345 # \cS - steal parens (see maybe_parens_unop)
346 # \n - newline and indent
347 # \t - increase indent
348 # \b - decrease indent ('outdent')
349 # \f - flush left (no indent)
350 # \cK - kill following semicolon, if any
351
352 # Semicolon handling:
353 #  - Individual statements are not deparsed with trailing semicolons.
354 #    (If necessary, \cK is tacked on to the end.)
355 #  - Whatever code joins statements together or emits them (lineseq,
356 #    scopeop, deparse_root) is responsible for adding semicolons where
357 #    necessary.
358 #  - use statements are deparsed with trailing semicolons because they are
359 #    immediately concatenated with the following statement.
360 #  - indent() removes semicolons wherever it sees \cK.
361
362
363 BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
364                  nextstate dbstate rv2av rv2hv helem custom ]) {
365     eval "sub OP_\U$_ () { " . opnumber($_) . "}"
366 }}
367
368 # _pessimise_walk(): recursively walk the optree of a sub,
369 # possibly undoing optimisations along the way.
370
371 sub _pessimise_walk {
372     my ($self, $startop) = @_;
373
374     return unless $$startop;
375     my ($op, $prevop);
376     for ($op = $startop; $$op; $prevop = $op, $op = $op->sibling) {
377         my $ppname = $op->name;
378
379         # pessimisations start here
380
381         if ($ppname eq "padrange") {
382             # remove PADRANGE:
383             # the original optimisation either (1) changed this:
384             #    pushmark -> (various pad and list and null ops) -> the_rest
385             # or (2), for the = @_ case, changed this:
386             #    pushmark -> gv[_] -> rv2av -> (pad stuff)       -> the_rest
387             # into this:
388             #    padrange ----------------------------------------> the_rest
389             # so we just need to convert the padrange back into a
390             # pushmark, and in case (1), set its op_next to op_sibling,
391             # which is the head of the original chain of optimised-away
392             # pad ops, or for (2), set it to sibling->first, which is
393             # the original gv[_].
394
395             $B::overlay->{$$op} = {
396                     type => OP_PUSHMARK,
397                     name => 'pushmark',
398                     private => ($op->private & OPpLVAL_INTRO),
399             };
400         }
401
402         # pessimisations end here
403
404         if (class($op) eq 'PMOP'
405             && ref($op->pmreplroot)
406             && ${$op->pmreplroot}
407             && $op->pmreplroot->isa( 'B::OP' ))
408         {
409             $self-> _pessimise_walk($op->pmreplroot);
410         }
411
412         if ($op->flags & OPf_KIDS) {
413             $self-> _pessimise_walk($op->first);
414         }
415
416     }
417 }
418
419
420 # _pessimise_walk_exe(): recursively walk the op_next chain of a sub,
421 # possibly undoing optimisations along the way.
422
423 sub _pessimise_walk_exe {
424     my ($self, $startop, $visited) = @_;
425
426     return unless $$startop;
427     return if $visited->{$$startop};
428     my ($op, $prevop);
429     for ($op = $startop; $$op; $prevop = $op, $op = $op->next) {
430         last if $visited->{$$op};
431         $visited->{$$op} = 1;
432         my $ppname = $op->name;
433         if ($ppname =~
434             /^((and|d?or)(assign)?|(map|grep)while|range|cond_expr|once)$/
435             # entertry is also a logop, but its op_other invariably points
436             # into the same chain as the main execution path, so we skip it
437         ) {
438             $self->_pessimise_walk_exe($op->other, $visited);
439         }
440         elsif ($ppname eq "subst") {
441             $self->_pessimise_walk_exe($op->pmreplstart, $visited);
442         }
443         elsif ($ppname =~ /^(enter(loop|iter))$/) {
444             # redoop and nextop will already be covered by the main block
445             # of the loop
446             $self->_pessimise_walk_exe($op->lastop, $visited);
447         }
448
449         # pessimisations start here
450     }
451 }
452
453 # Go through an optree and "remove" some optimisations by using an
454 # overlay to selectively modify or un-null some ops. Deparsing in the
455 # absence of those optimisations is then easier.
456 #
457 # Note that older optimisations are not removed, as Deparse was already
458 # written to recognise them before the pessimise/overlay system was added.
459
460 sub pessimise {
461     my ($self, $root, $start) = @_;
462
463     # walk tree in root-to-branch order
464     $self->_pessimise_walk($root);
465
466     my %visited;
467     # walk tree in execution order
468     $self->_pessimise_walk_exe($start, \%visited);
469 }
470
471
472 sub null {
473     my $op = shift;
474     return class($op) eq "NULL";
475 }
476
477 sub todo {
478     my $self = shift;
479     my($cv, $is_form, $name) = @_;
480     my $cvfile = $cv->FILE//'';
481     return unless ($cvfile eq $0 || exists $self->{files}{$cvfile});
482     my $seq;
483     if ($cv->OUTSIDE_SEQ) {
484         $seq = $cv->OUTSIDE_SEQ;
485     } elsif (!null($cv->START) and is_state($cv->START)) {
486         $seq = $cv->START->cop_seq;
487     } else {
488         $seq = 0;
489     }
490     push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form, $name];
491 }
492
493 sub next_todo {
494     my $self = shift;
495     my $ent = shift @{$self->{'subs_todo'}};
496     my ($seq, $cv, $is_form, $name) = @$ent;
497
498     # any 'use strict; package foo' that should come before the sub
499     # declaration to sync with the first COP of the sub
500     my $pragmata = '';
501     if ($cv and !null($cv->START) and is_state($cv->START))  {
502         $pragmata = $self->pragmata($cv->START);
503     }
504
505     if (ref $name) { # lexical sub
506         # emit the sub.
507         my @text;
508         my $flags = $name->FLAGS;
509         push @text,
510             !$cv || $seq <= $name->COP_SEQ_RANGE_LOW
511                 ? $self->keyword($flags & SVpad_OUR
512                                     ? "our"
513                                     : $flags & SVpad_STATE
514                                         ? "state"
515                                         : "my") . " "
516                 : "";
517         # XXX We would do $self->keyword("sub"), but ‘my CORE::sub’
518         #     doesn’t work and ‘my sub’ ignores a &sub in scope.  I.e.,
519         #     we have a core bug here.
520         push @text, "sub " . substr $name->PVX, 1;
521         if ($cv) {
522             # my sub foo { }
523             push @text,  " " . $self->deparse_sub($cv);
524             $text[-1] =~ s/ ;$/;/;
525         }
526         else {
527             # my sub foo;
528             push @text, ";\n";
529         }
530         return $pragmata . join "", @text;
531     }
532
533     my $gv = $cv->GV;
534     $name //= $self->gv_name($gv);
535     if ($is_form) {
536         return $pragmata . $self->keyword("format") . " $name =\n"
537             . $self->deparse_format($cv). "\n";
538     } else {
539         my $use_dec;
540         if ($name eq "BEGIN") {
541             $use_dec = $self->begin_is_use($cv);
542             if (defined ($use_dec) and $self->{'expand'} < 5) {
543                 return $pragmata if 0 == length($use_dec);
544                 $use_dec =~ s/^(use|no)\b/$self->keyword($1)/e;
545             }
546         }
547         my $l = '';
548         if ($self->{'linenums'}) {
549             my $line = $gv->LINE;
550             my $file = $gv->FILE;
551             $l = "\n\f#line $line \"$file\"\n";
552         }
553         my $p = '';
554         my $stash;
555         if (class($cv->STASH) ne "SPECIAL") {
556             $stash = $cv->STASH->NAME;
557             if ($stash ne $self->{'curstash'}) {
558                 $p = $self->keyword("package") . " $stash;\n";
559                 $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
560                 $self->{'curstash'} = $stash;
561             }
562         }
563         if ($use_dec) {
564             return "$pragmata$p$l$use_dec";
565         }
566         if ( $name !~ /::/ and $self->lex_in_scope("&$name")
567                             || $self->lex_in_scope("&$name", 1) )
568         {
569             $name = "$self->{'curstash'}::$name";
570         } elsif (defined $stash) {
571             $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
572         }
573         my $ret = "$pragmata${p}${l}" . $self->keyword("sub") . " $name "
574               . $self->deparse_sub($cv);
575         $self->{'subs_declared'}{$name} = 1;
576         return $ret;
577     }
578 }
579
580
581 # Return a "use" declaration for this BEGIN block, if appropriate
582 sub begin_is_use {
583     my ($self, $cv) = @_;
584     my $root = $cv->ROOT;
585     local @$self{qw'curcv curcvlex'} = ($cv);
586     local $B::overlay = {};
587     $self->pessimise($root, $cv->START);
588 #require B::Debug;
589 #B::walkoptree($cv->ROOT, "debug");
590     my $lineseq = $root->first;
591     return if $lineseq->name ne "lineseq";
592
593     my $req_op = $lineseq->first->sibling;
594     return if $req_op->name ne "require";
595
596     my $module;
597     if ($req_op->first->private & OPpCONST_BARE) {
598         # Actually it should always be a bareword
599         $module = $self->const_sv($req_op->first)->PV;
600         $module =~ s[/][::]g;
601         $module =~ s/.pm$//;
602     }
603     else {
604         $module = $self->const($self->const_sv($req_op->first), 6);
605     }
606
607     my $version;
608     my $version_op = $req_op->sibling;
609     return if class($version_op) eq "NULL";
610     if ($version_op->name eq "lineseq") {
611         # We have a version parameter; skip nextstate & pushmark
612         my $constop = $version_op->first->next->next;
613
614         return unless $self->const_sv($constop)->PV eq $module;
615         $constop = $constop->sibling;
616         $version = $self->const_sv($constop);
617         if (class($version) eq "IV") {
618             $version = $version->int_value;
619         } elsif (class($version) eq "NV") {
620             $version = $version->NV;
621         } elsif (class($version) ne "PVMG") {
622             # Includes PVIV and PVNV
623             $version = $version->PV;
624         } else {
625             # version specified as a v-string
626             $version = 'v'.join '.', map ord, split //, $version->PV;
627         }
628         $constop = $constop->sibling;
629         return if $constop->name ne "method_named";
630         return if $self->meth_sv($constop)->PV ne "VERSION";
631     }
632
633     $lineseq = $version_op->sibling;
634     return if $lineseq->name ne "lineseq";
635     my $entersub = $lineseq->first->sibling;
636     if ($entersub->name eq "stub") {
637         return "use $module $version ();\n" if defined $version;
638         return "use $module ();\n";
639     }
640     return if $entersub->name ne "entersub";
641
642     # See if there are import arguments
643     my $args = '';
644
645     my $svop = $entersub->first->sibling; # Skip over pushmark
646     return unless $self->const_sv($svop)->PV eq $module;
647
648     # Pull out the arguments
649     for ($svop=$svop->sibling; index($svop->name, "method_") != 0;
650                 $svop = $svop->sibling) {
651         $args .= ", " if length($args);
652         $args .= $self->deparse($svop, 6);
653     }
654
655     my $use = 'use';
656     my $method_named = $svop;
657     return if $method_named->name ne "method_named";
658     my $method_name = $self->meth_sv($method_named)->PV;
659
660     if ($method_name eq "unimport") {
661         $use = 'no';
662     }
663
664     # Certain pragmas are dealt with using hint bits,
665     # so we ignore them here
666     if ($module eq 'strict' || $module eq 'integer'
667         || $module eq 'bytes' || $module eq 'warnings'
668         || $module eq 'feature') {
669         return "";
670     }
671
672     if (defined $version && length $args) {
673         return "$use $module $version ($args);\n";
674     } elsif (defined $version) {
675         return "$use $module $version;\n";
676     } elsif (length $args) {
677         return "$use $module ($args);\n";
678     } else {
679         return "$use $module;\n";
680     }
681 }
682
683 sub stash_subs {
684     my ($self, $pack, $seen) = @_;
685     my (@ret, $stash);
686     if (!defined $pack) {
687         $pack = '';
688         $stash = \%::;
689     }
690     else {
691         $pack =~ s/(::)?$/::/;
692         no strict 'refs';
693         $stash = \%{"main::$pack"};
694     }
695     return
696         if ($seen ||= {})->{
697             $INC{"overload.pm"} ? overload::StrVal($stash) : $stash
698            }++;
699     my %stash = svref_2object($stash)->ARRAY;
700     while (my ($key, $val) = each %stash) {
701         my $flags = $val->FLAGS;
702         if ($flags & SVf_ROK) {
703             # A reference.  Dump this if it is a reference to a CV.  If it
704             # is a constant acting as a proxy for a full subroutine, then
705             # we may or may not have to dump it.  If some form of perl-
706             # space visible code must have created it, be it a use
707             # statement, or some direct symbol-table manipulation code that
708             # we will deparse, then we don’t want to dump it.  If it is the
709             # result of a declaration like sub f () { 42 } then we *do*
710             # want to dump it.  The only way to distinguish these seems
711             # to be the SVs_PADTMP flag on the constant, which is admit-
712             # tedly a hack.
713             my $class = class(my $referent = $val->RV);
714             if ($class eq "CV") {
715                 $self->todo($referent, 0);
716             } elsif (
717                 $class !~ /^(AV|HV|CV|FM|IO|SPECIAL)\z/
718                 # A more robust way to write that would be this, but B does
719                 # not provide the SVt_ constants:
720                 # ($referent->FLAGS & B::SVTYPEMASK) < B::SVt_PVAV
721                 and $referent->FLAGS & SVs_PADTMP
722             ) {
723                 push @{$self->{'protos_todo'}}, [$pack . $key, $val];
724             }
725         } elsif ($flags & (SVf_POK|SVf_IOK)) {
726             # Just a prototype. As an ugly but fairly effective way
727             # to find out if it belongs here is to see if the AUTOLOAD
728             # (if any) for the stash was defined in one of our files.
729             my $A = $stash{"AUTOLOAD"};
730             if (defined ($A) && class($A) eq "GV" && defined($A->CV)
731                 && class($A->CV) eq "CV") {
732                 my $AF = $A->FILE;
733                 next unless $AF eq $0 || exists $self->{'files'}{$AF};
734             }
735             push @{$self->{'protos_todo'}},
736                  [$pack . $key, $flags & SVf_POK ? $val->PV: undef];
737         } elsif (class($val) eq "GV") {
738             if (class(my $cv = $val->CV) ne "SPECIAL") {
739                 next if $self->{'subs_done'}{$$val}++;
740                 next if $$val != ${$cv->GV};   # Ignore imposters
741                 $self->todo($cv, 0);
742             }
743             if (class(my $cv = $val->FORM) ne "SPECIAL") {
744                 next if $self->{'forms_done'}{$$val}++;
745                 next if $$val != ${$cv->GV};   # Ignore imposters
746                 $self->todo($cv, 1);
747             }
748             if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
749                 $self->stash_subs($pack . $key, $seen);
750             }
751         }
752     }
753 }
754
755 sub print_protos {
756     my $self = shift;
757     my $ar;
758     my @ret;
759     foreach $ar (@{$self->{'protos_todo'}}) {
760         my $body = defined $ar->[1]
761                 ? ref $ar->[1]
762                     ? " () {\n    " . $self->const($ar->[1]->RV,0) . ";\n}"
763                     : " (". $ar->[1] . ");"
764                 : ";";
765         push @ret, "sub " . $ar->[0] .  "$body\n";
766     }
767     delete $self->{'protos_todo'};
768     return @ret;
769 }
770
771 sub style_opts {
772     my $self = shift;
773     my $opts = shift;
774     my $opt;
775     while (length($opt = substr($opts, 0, 1))) {
776         if ($opt eq "C") {
777             $self->{'cuddle'} = " ";
778             $opts = substr($opts, 1);
779         } elsif ($opt eq "i") {
780             $opts =~ s/^i(\d+)//;
781             $self->{'indent_size'} = $1;
782         } elsif ($opt eq "T") {
783             $self->{'use_tabs'} = 1;
784             $opts = substr($opts, 1);
785         } elsif ($opt eq "v") {
786             $opts =~ s/^v([^.]*)(.|$)//;
787             $self->{'ex_const'} = $1;
788         }
789     }
790 }
791
792 sub new {
793     my $class = shift;
794     my $self = bless {}, $class;
795     $self->{'cuddle'} = "\n";
796     $self->{'curcop'} = undef;
797     $self->{'curstash'} = "main";
798     $self->{'ex_const'} = "'???'";
799     $self->{'expand'} = 0;
800     $self->{'files'} = {};
801     $self->{'indent_size'} = 4;
802     $self->{'linenums'} = 0;
803     $self->{'parens'} = 0;
804     $self->{'subs_todo'} = [];
805     $self->{'unquote'} = 0;
806     $self->{'use_dumper'} = 0;
807     $self->{'use_tabs'} = 0;
808
809     $self->{'ambient_arybase'} = 0;
810     $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
811     $self->{'ambient_hints'} = 0;
812     $self->{'ambient_hinthash'} = undef;
813     $self->init();
814
815     while (my $arg = shift @_) {
816         if ($arg eq "-d") {
817             $self->{'use_dumper'} = 1;
818             require Data::Dumper;
819         } elsif ($arg =~ /^-f(.*)/) {
820             $self->{'files'}{$1} = 1;
821         } elsif ($arg eq "-l") {
822             $self->{'linenums'} = 1;
823         } elsif ($arg eq "-p") {
824             $self->{'parens'} = 1;
825         } elsif ($arg eq "-P") {
826             $self->{'noproto'} = 1;
827         } elsif ($arg eq "-q") {
828             $self->{'unquote'} = 1;
829         } elsif (substr($arg, 0, 2) eq "-s") {
830             $self->style_opts(substr $arg, 2);
831         } elsif ($arg =~ /^-x(\d)$/) {
832             $self->{'expand'} = $1;
833         }
834     }
835     return $self;
836 }
837
838 {
839     # Mask out the bits that L<warnings::register> uses
840     my $WARN_MASK;
841     BEGIN {
842         $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
843     }
844     sub WARN_MASK () {
845         return $WARN_MASK;
846     }
847 }
848
849 # Initialise the contextual information, either from
850 # defaults provided with the ambient_pragmas method,
851 # or from perl's own defaults otherwise.
852 sub init {
853     my $self = shift;
854
855     $self->{'arybase'}  = $self->{'ambient_arybase'};
856     $self->{'warnings'} = defined ($self->{'ambient_warnings'})
857                                 ? $self->{'ambient_warnings'} & WARN_MASK
858                                 : undef;
859     $self->{'hints'}    = $self->{'ambient_hints'};
860     $self->{'hints'} &= 0xFF if $] < 5.009;
861     $self->{'hinthash'} = $self->{'ambient_hinthash'};
862
863     # also a convenient place to clear out subs_declared
864     delete $self->{'subs_declared'};
865 }
866
867 sub compile {
868     my(@args) = @_;
869     return sub {
870         my $self = B::Deparse->new(@args);
871         # First deparse command-line args
872         if (defined $^I) { # deparse -i
873             print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
874         }
875         if ($^W) { # deparse -w
876             print qq(BEGIN { \$^W = $^W; }\n);
877         }
878         if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
879             my $fs = perlstring($/) || 'undef';
880             my $bs = perlstring($O::savebackslash) || 'undef';
881             print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
882         }
883         my @BEGINs  = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
884         my @UNITCHECKs = B::unitcheck_av->isa("B::AV")
885             ? B::unitcheck_av->ARRAY
886             : ();
887         my @CHECKs  = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
888         my @INITs   = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
889         my @ENDs    = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
890         my @names = qw(BEGIN UNITCHECK CHECK INIT END);
891         my @blocks = \(@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs);
892         while (@names) {
893             my ($name, $blocks) = (shift @names, shift @blocks);
894             for my $block (@$blocks) {
895                 $self->todo($block, 0, $name);
896             }
897         }
898         $self->stash_subs();
899         local($SIG{"__DIE__"}) =
900           sub {
901               if ($self->{'curcop'}) {
902                   my $cop = $self->{'curcop'};
903                   my($line, $file) = ($cop->line, $cop->file);
904                   print STDERR "While deparsing $file near line $line,\n";
905               }
906             };
907         $self->{'curcv'} = main_cv;
908         $self->{'curcvlex'} = undef;
909         print $self->print_protos;
910         @{$self->{'subs_todo'}} =
911           sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
912         my $root = main_root;
913         local $B::overlay = {};
914         unless (null $root) {
915             $self->pad_subs($self->{'curcv'});
916             # Check for a stub-followed-by-ex-cop, resulting from a program
917             # consisting solely of sub declarations.  For backward-compati-
918             # bility (and sane output) we don’t want to emit the stub.
919             #   leave
920             #     enter
921             #     stub
922             #     ex-nextstate (or ex-dbstate)
923             my $kid;
924             if ( $root->name eq 'leave'
925              and ($kid = $root->first)->name eq 'enter'
926              and !null($kid = $kid->sibling) and $kid->name eq 'stub'
927              and !null($kid = $kid->sibling) and $kid->name eq 'null'
928              and class($kid) eq 'COP' and null $kid->sibling )
929             {
930                 # ignore
931             } else {
932                 $self->pessimise($root, main_start);
933                 print $self->indent($self->deparse_root($root)), "\n";
934             }
935         }
936         my @text;
937         while (scalar(@{$self->{'subs_todo'}})) {
938             push @text, $self->next_todo;
939         }
940         print $self->indent(join("", @text)), "\n" if @text;
941
942         # Print __DATA__ section, if necessary
943         no strict 'refs';
944         my $laststash = defined $self->{'curcop'}
945             ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
946         if (defined *{$laststash."::DATA"}{IO}) {
947             print $self->keyword("package") . " $laststash;\n"
948                 unless $laststash eq $self->{'curstash'};
949             print $self->keyword("__DATA__") . "\n";
950             print readline(*{$laststash."::DATA"});
951         }
952     }
953 }
954
955 sub coderef2text {
956     my $self = shift;
957     my $sub = shift;
958     croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
959
960     $self->init();
961     local $self->{in_coderef2text} = 1;
962     return $self->indent($self->deparse_sub(svref_2object($sub)));
963 }
964
965 my %strict_bits = do {
966     local $^H;
967     map +($_ => strict::bits($_)), qw/refs subs vars/
968 };
969
970 sub ambient_pragmas {
971     my $self = shift;
972     my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
973
974     while (@_ > 1) {
975         my $name = shift();
976         my $val  = shift();
977
978         if ($name eq 'strict') {
979             require strict;
980
981             if ($val eq 'none') {
982                 $hint_bits &= $strict_bits{$_} for qw/refs subs vars/;
983                 next();
984             }
985
986             my @names;
987             if ($val eq "all") {
988                 @names = qw/refs subs vars/;
989             }
990             elsif (ref $val) {
991                 @names = @$val;
992             }
993             else {
994                 @names = split' ', $val;
995             }
996             $hint_bits |= $strict_bits{$_} for @names;
997         }
998
999         elsif ($name eq '$[') {
1000             if (OPpCONST_ARYBASE) {
1001                 $arybase = $val;
1002             } else {
1003                 croak "\$[ can't be non-zero on this perl" unless $val == 0;
1004             }
1005         }
1006
1007         elsif ($name eq 'integer'
1008             || $name eq 'bytes'
1009             || $name eq 'utf8') {
1010             require "$name.pm";
1011             if ($val) {
1012                 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
1013             }
1014             else {
1015                 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
1016             }
1017         }
1018
1019         elsif ($name eq 're') {
1020             require re;
1021             if ($val eq 'none') {
1022                 $hint_bits &= ~re::bits(qw/taint eval/);
1023                 next();
1024             }
1025
1026             my @names;
1027             if ($val eq 'all') {
1028                 @names = qw/taint eval/;
1029             }
1030             elsif (ref $val) {
1031                 @names = @$val;
1032             }
1033             else {
1034                 @names = split' ',$val;
1035             }
1036             $hint_bits |= re::bits(@names);
1037         }
1038
1039         elsif ($name eq 'warnings') {
1040             if ($val eq 'none') {
1041                 $warning_bits = $warnings::NONE;
1042                 next();
1043             }
1044
1045             my @names;
1046             if (ref $val) {
1047                 @names = @$val;
1048             }
1049             else {
1050                 @names = split/\s+/, $val;
1051             }
1052
1053             $warning_bits = $warnings::NONE if !defined ($warning_bits);
1054             $warning_bits |= warnings::bits(@names);
1055         }
1056
1057         elsif ($name eq 'warning_bits') {
1058             $warning_bits = $val;
1059         }
1060
1061         elsif ($name eq 'hint_bits') {
1062             $hint_bits = $val;
1063         }
1064
1065         elsif ($name eq '%^H') {
1066             $hinthash = $val;
1067         }
1068
1069         else {
1070             croak "Unknown pragma type: $name";
1071         }
1072     }
1073     if (@_) {
1074         croak "The ambient_pragmas method expects an even number of args";
1075     }
1076
1077     $self->{'ambient_arybase'} = $arybase;
1078     $self->{'ambient_warnings'} = $warning_bits;
1079     $self->{'ambient_hints'} = $hint_bits;
1080     $self->{'ambient_hinthash'} = $hinthash;
1081 }
1082
1083 # This method is the inner loop, so try to keep it simple
1084 sub deparse {
1085     my $self = shift;
1086     my($op, $cx) = @_;
1087
1088     Carp::confess("Null op in deparse") if !defined($op)
1089                                         || class($op) eq "NULL";
1090     my $meth = "pp_" . $op->name;
1091     return $self->$meth($op, $cx);
1092 }
1093
1094 sub indent {
1095     my $self = shift;
1096     my $txt = shift;
1097     # \cK also swallows a preceding line break when followed by a
1098     # semicolon.
1099     $txt =~ s/\n\cK;//g;
1100     my @lines = split(/\n/, $txt);
1101     my $leader = "";
1102     my $level = 0;
1103     my $line;
1104     for $line (@lines) {
1105         my $cmd = substr($line, 0, 1);
1106         if ($cmd eq "\t" or $cmd eq "\b") {
1107             $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
1108             if ($self->{'use_tabs'}) {
1109                 $leader = "\t" x ($level / 8) . " " x ($level % 8);
1110             } else {
1111                 $leader = " " x $level;
1112             }
1113             $line = substr($line, 1);
1114         }
1115         if (index($line, "\f") > 0) {
1116                 $line =~ s/\f/\n/;
1117         }
1118         if (substr($line, 0, 1) eq "\f") {
1119             $line = substr($line, 1); # no indent
1120         } else {
1121             $line = $leader . $line;
1122         }
1123         $line =~ s/\cK;?//g;
1124     }
1125     return join("\n", @lines);
1126 }
1127
1128 sub pad_subs {
1129     my ($self, $cv) = @_;
1130     my $padlist = $cv->PADLIST;
1131     my @names = $padlist->ARRAYelt(0)->ARRAY;
1132     my @values = $padlist->ARRAYelt(1)->ARRAY;
1133     my @todo;
1134   PADENTRY:
1135     for my $ix (0.. $#names) { for $_ ($names[$ix]) {
1136         next if class($_) eq "SPECIAL";
1137         my $name = $_->PVX;
1138         if (defined $name && $name =~ /^&./) {
1139             my $low = $_->COP_SEQ_RANGE_LOW;
1140             my $flags = $_->FLAGS;
1141             my $outer = $flags & PADNAMEt_OUTER;
1142             if ($flags & SVpad_OUR) {
1143                 push @todo, [$low, undef, 0, $_]
1144                           # [seq, no cv, not format, padname]
1145                     unless $outer;
1146                 next;
1147             }
1148             my $protocv = $flags & SVpad_STATE
1149                 ? $values[$ix]
1150                 : $_->PROTOCV;
1151             if (class ($protocv) ne 'CV') {
1152                 my $flags = $flags;
1153                 my $cv = $cv;
1154                 my $name = $_;
1155                 while ($flags & PADNAMEt_OUTER && class ($protocv) ne 'CV')
1156                 {
1157                     $cv = $cv->OUTSIDE;
1158                     next PADENTRY if class($cv) eq 'SPECIAL'; # XXX freed?
1159                     my $padlist = $cv->PADLIST;
1160                     my $ix = $name->PARENT_PAD_INDEX;
1161                     $name = $padlist->NAMES->ARRAYelt($ix);
1162                     $flags = $name->FLAGS;
1163                     $protocv = $flags & SVpad_STATE
1164                         ? $padlist->ARRAYelt(1)->ARRAYelt($ix)
1165                         : $name->PROTOCV;
1166                 }
1167             }
1168             my $defined_in_this_sub = ${$protocv->OUTSIDE} == $$cv || do {
1169                 my $other = $protocv->PADLIST;
1170                 $$other && $other->outid == $padlist->id;
1171             };
1172             if ($flags & PADNAMEt_OUTER) {
1173                 next unless $defined_in_this_sub;
1174                 push @todo, [$protocv->OUTSIDE_SEQ, $protocv, 0, $_];
1175                 next;
1176             }
1177             my $outseq = $protocv->OUTSIDE_SEQ;
1178             if ($outseq <= $low) {
1179                 # defined before its name is visible, so it’s gotta be
1180                 # declared and defined at once: my sub foo { ... }
1181                 push @todo, [$low, $protocv, 0, $_];
1182             }
1183             else {
1184                 # declared and defined separately: my sub f; sub f { ... }
1185                 push @todo, [$low, undef, 0, $_];
1186                 push @todo, [$outseq, $protocv, 0, $_]
1187                     if $defined_in_this_sub;
1188             }
1189         }
1190     }}
1191     @{$self->{'subs_todo'}} =
1192         sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo
1193 }
1194
1195 sub deparse_sub {
1196     my $self = shift;
1197     my $cv = shift;
1198     my @attrs;
1199     my $protosig; # prototype or signature (what goes in the (....))
1200
1201 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
1202 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
1203     local $self->{'curcop'} = $self->{'curcop'};
1204
1205     my $has_sig = $self->{hinthash}{feature_signatures};
1206     if ($cv->FLAGS & SVf_POK) {
1207         my $proto = $cv->PV;
1208         if ($has_sig) {
1209             push @attrs, "prototype($proto)";
1210         }
1211         else {
1212             $protosig = $proto;
1213         }
1214     }
1215     if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ANONCONST)) {
1216         push @attrs, "lvalue" if $cv->CvFLAGS & CVf_LVALUE;
1217         push @attrs, "locked" if $cv->CvFLAGS & CVf_LOCKED;
1218         push @attrs, "method" if $cv->CvFLAGS & CVf_METHOD;
1219         push @attrs, "const"  if $cv->CvFLAGS & CVf_ANONCONST;
1220     }
1221
1222     local($self->{'curcv'}) = $cv;
1223     local($self->{'curcvlex'});
1224     local(@$self{qw'curstash warnings hints hinthash'})
1225                 = @$self{qw'curstash warnings hints hinthash'};
1226     my $body;
1227     my $root = $cv->ROOT;
1228     local $B::overlay = {};
1229     if (not null $root) {
1230         $self->pad_subs($cv);
1231         $self->pessimise($root, $cv->START);
1232         my $lineseq = $root->first;
1233         if ($lineseq->name eq "lineseq") {
1234             my @ops;
1235             for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
1236                 push @ops, $o;
1237             }
1238             $body = $self->lineseq(undef, 0, @ops).";";
1239             if ($ops[-1]->name =~ /^(next|db)state$/) {
1240                 # this handles void context in
1241                 #   use feature signatures; sub ($=1) {}
1242                 $body .= "\n()";
1243             }
1244             my $scope_en = $self->find_scope_en($lineseq);
1245             if (defined $scope_en) {
1246                 my $subs = join"", $self->seq_subs($scope_en);
1247                 $body .= ";\n$subs" if length($subs);
1248             }
1249         }
1250         else {
1251             $body = $self->deparse($root->first, 0);
1252         }
1253         $body = "{\n\t$body\n\b}";
1254     }
1255     else {
1256         my $sv = $cv->const_sv;
1257         if ($$sv) {
1258             # uh-oh. inlinable sub... format it differently
1259             $body = "{ " . $self->const($sv, 0) . " }\n";
1260         } else { # XSUB? (or just a declaration)
1261             $body = ';'
1262         }
1263     }
1264     $protosig = defined $protosig ? "($protosig) " : "";
1265     my $attrs = '';
1266     $attrs = ': ' . join('', map "$_ ", @attrs) if @attrs;
1267     return "$protosig$attrs$body\n";
1268 }
1269
1270 sub deparse_format {
1271     my $self = shift;
1272     my $form = shift;
1273     my @text;
1274     local($self->{'curcv'}) = $form;
1275     local($self->{'curcvlex'});
1276     local($self->{'in_format'}) = 1;
1277     local(@$self{qw'curstash warnings hints hinthash'})
1278                 = @$self{qw'curstash warnings hints hinthash'};
1279     my $op = $form->ROOT;
1280     local $B::overlay = {};
1281     $self->pessimise($op, $form->START);
1282     my $kid;
1283     return "\f." if $op->first->name eq 'stub'
1284                 || $op->first->name eq 'nextstate';
1285     $op = $op->first->first; # skip leavewrite, lineseq
1286     while (not null $op) {
1287         $op = $op->sibling; # skip nextstate
1288         my @exprs;
1289         $kid = $op->first->sibling; # skip pushmark
1290         push @text, "\f".$self->const_sv($kid)->PV;
1291         $kid = $kid->sibling;
1292         for (; not null $kid; $kid = $kid->sibling) {
1293             push @exprs, $self->deparse($kid, -1);
1294             $exprs[-1] =~ s/;\z//;
1295         }
1296         push @text, "\f".join(", ", @exprs)."\n" if @exprs;
1297         $op = $op->sibling;
1298     }
1299     return join("", @text) . "\f.";
1300 }
1301
1302 sub is_scope {
1303     my $op = shift;
1304     return $op->name eq "leave" || $op->name eq "scope"
1305       || $op->name eq "lineseq"
1306         || ($op->name eq "null" && class($op) eq "UNOP"
1307             && (is_scope($op->first) || $op->first->name eq "enter"));
1308 }
1309
1310 sub is_state {
1311     my $name = $_[0]->name;
1312     return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
1313 }
1314
1315 sub is_miniwhile { # check for one-line loop ('foo() while $y--')
1316     my $op = shift;
1317     return (!null($op) and null($op->sibling)
1318             and $op->name eq "null" and class($op) eq "UNOP"
1319             and (($op->first->name =~ /^(and|or)$/
1320                   and $op->first->first->sibling->name eq "lineseq")
1321                  or ($op->first->name eq "lineseq"
1322                      and not null $op->first->first->sibling
1323                      and $op->first->first->sibling->name eq "unstack")
1324                  ));
1325 }
1326
1327 # Check if the op and its sibling are the initialization and the rest of a
1328 # for (..;..;..) { ... } loop
1329 sub is_for_loop {
1330     my $op = shift;
1331     # This OP might be almost anything, though it won't be a
1332     # nextstate. (It's the initialization, so in the canonical case it
1333     # will be an sassign.) The sibling is (old style) a lineseq whose
1334     # first child is a nextstate and whose second is a leaveloop, or
1335     # (new style) an unstack whose sibling is a leaveloop.
1336     my $lseq = $op->sibling;
1337     return 0 unless !is_state($op) and !null($lseq);
1338     if ($lseq->name eq "lineseq") {
1339         if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
1340             && (my $sib = $lseq->first->sibling)) {
1341             return (!null($sib) && $sib->name eq "leaveloop");
1342         }
1343     } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) {
1344         my $sib = $lseq->sibling;
1345         return $sib && !null($sib) && $sib->name eq "leaveloop";
1346     }
1347     return 0;
1348 }
1349
1350 sub is_scalar {
1351     my $op = shift;
1352     return ($op->name eq "rv2sv" or
1353             $op->name eq "padsv" or
1354             $op->name eq "gv" or # only in array/hash constructs
1355             $op->flags & OPf_KIDS && !null($op->first)
1356               && $op->first->name eq "gvsv");
1357 }
1358
1359 sub maybe_parens {
1360     my $self = shift;
1361     my($text, $cx, $prec) = @_;
1362     if ($prec < $cx              # unary ops nest just fine
1363         or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
1364         or $self->{'parens'})
1365     {
1366         $text = "($text)";
1367         # In a unop, let parent reuse our parens; see maybe_parens_unop
1368         $text = "\cS" . $text if $cx == 16;
1369         return $text;
1370     } else {
1371         return $text;
1372     }
1373 }
1374
1375 # same as above, but get around the 'if it looks like a function' rule
1376 sub maybe_parens_unop {
1377     my $self = shift;
1378     my($name, $kid, $cx) = @_;
1379     if ($cx > 16 or $self->{'parens'}) {
1380         $kid =  $self->deparse($kid, 1);
1381         if ($name eq "umask" && $kid =~ /^\d+$/) {
1382             $kid = sprintf("%#o", $kid);
1383         }
1384         return $self->keyword($name) . "($kid)";
1385     } else {
1386         $kid = $self->deparse($kid, 16);
1387         if ($name eq "umask" && $kid =~ /^\d+$/) {
1388             $kid = sprintf("%#o", $kid);
1389         }
1390         $name = $self->keyword($name);
1391         if (substr($kid, 0, 1) eq "\cS") {
1392             # use kid's parens
1393             return $name . substr($kid, 1);
1394         } elsif (substr($kid, 0, 1) eq "(") {
1395             # avoid looks-like-a-function trap with extra parens
1396             # ('+' can lead to ambiguities)
1397             return "$name(" . $kid  . ")";
1398         } else {
1399             return "$name $kid";
1400         }
1401     }
1402 }
1403
1404 sub maybe_parens_func {
1405     my $self = shift;
1406     my($func, $text, $cx, $prec) = @_;
1407     if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
1408         return "$func($text)";
1409     } else {
1410         return "$func $text";
1411     }
1412 }
1413
1414 sub find_our_type {
1415     my ($self, $name) = @_;
1416     $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1417     my $seq = $self->{'curcop'} ? $self->{'curcop'}->cop_seq : 0;
1418     for my $a (@{$self->{'curcvlex'}{"o$name"}}) {
1419         my ($st, undef, $padname) = @$a;
1420         if ($st >= $seq && $padname->FLAGS & SVpad_TYPED) {
1421             return $padname->SvSTASH->NAME;
1422         }
1423     }
1424     return '';
1425 }
1426
1427 sub maybe_local {
1428     my $self = shift;
1429     my($op, $cx, $text) = @_;
1430     my $name = $op->name;
1431     my $our_intro = ($name =~ /^(?:(?:gv|rv2)[ash]v|split|refassign
1432                                   |lv(?:av)?ref)$/x)
1433                         ? OPpOUR_INTRO
1434                         : 0;
1435     my $lval_intro = $name eq 'split' ? 0 : OPpLVAL_INTRO;
1436     # The @a in \(@a) isn't in ref context, but only when the
1437     # parens are there.
1438     my $need_parens = $self->{'in_refgen'} && $name =~ /[ah]v\z/
1439                    && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
1440     if ((my $priv = $op->private) & ($lval_intro|$our_intro)) {
1441         my @our_local;
1442         push @our_local, "local" if $priv & $lval_intro;
1443         push @our_local, "our"   if $priv & $our_intro;
1444         my $our_local = join " ", map $self->keyword($_), @our_local;
1445         if( $our_local[-1] eq 'our' ) {
1446             if ( $text !~ /^\W(\w+::)*\w+\z/
1447              and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
1448             ) {
1449                 die "Unexpected our($text)\n";
1450             }
1451             $text =~ s/(\w+::)+//;
1452
1453             if (my $type = $self->find_our_type($text)) {
1454                 $our_local .= ' ' . $type;
1455             }
1456         }
1457         return $need_parens ? "($text)" : $text
1458             if $self->{'avoid_local'}{$$op};
1459         if ($need_parens) {
1460             return "$our_local($text)";
1461         } elsif (want_scalar($op)) {
1462             return "$our_local $text";
1463         } else {
1464             return $self->maybe_parens_func("$our_local", $text, $cx, 16);
1465         }
1466     } else {
1467         return $need_parens ? "($text)" : $text;
1468     }
1469 }
1470
1471 sub maybe_targmy {
1472     my $self = shift;
1473     my($op, $cx, $func, @args) = @_;
1474     if ($op->private & OPpTARGET_MY) {
1475         my $var = $self->padname($op->targ);
1476         my $val = $func->($self, $op, 7, @args);
1477         return $self->maybe_parens("$var = $val", $cx, 7);
1478     } else {
1479         return $func->($self, $op, $cx, @args);
1480     }
1481 }
1482
1483 sub padname_sv {
1484     my $self = shift;
1485     my $targ = shift;
1486     return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
1487 }
1488
1489 sub maybe_my {
1490     my $self = shift;
1491     my($op, $cx, $text, $padname, $forbid_parens) = @_;
1492     # The @a in \(@a) isn't in ref context, but only when the
1493     # parens are there.
1494     my $need_parens = !$forbid_parens && $self->{'in_refgen'}
1495                    && $op->name =~ /[ah]v\z/
1496                    && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
1497     # The @a in \my @a must not have parens.
1498     if (!$need_parens && $self->{'in_refgen'}) {
1499         $forbid_parens = 1;
1500     }
1501     if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
1502         # Check $padname->FLAGS for statehood, rather than $op->private,
1503         # because enteriter ops do not carry the flag.
1504         my $my =
1505             $self->keyword($padname->FLAGS & SVpad_STATE ? "state" : "my");
1506         if ($padname->FLAGS & SVpad_TYPED) {
1507             $my .= ' ' . $padname->SvSTASH->NAME;
1508         }
1509         if ($need_parens) {
1510             return "$my($text)";
1511         } elsif ($forbid_parens || want_scalar($op)) {
1512             return "$my $text";
1513         } else {
1514             return $self->maybe_parens_func($my, $text, $cx, 16);
1515         }
1516     } else {
1517         return $need_parens ? "($text)" : $text;
1518     }
1519 }
1520
1521 # The following OPs don't have functions:
1522
1523 # pp_padany -- does not exist after parsing
1524
1525 sub AUTOLOAD {
1526     if ($AUTOLOAD =~ s/^.*::pp_//) {
1527         warn "unexpected OP_".
1528           ($_[1]->type == OP_CUSTOM ? "CUSTOM ($AUTOLOAD)" : uc $AUTOLOAD);
1529         return "XXX";
1530     } else {
1531         die "Undefined subroutine $AUTOLOAD called";
1532     }
1533 }
1534
1535 sub DESTROY {}  #       Do not AUTOLOAD
1536
1537 # $root should be the op which represents the root of whatever
1538 # we're sequencing here. If it's undefined, then we don't append
1539 # any subroutine declarations to the deparsed ops, otherwise we
1540 # append appropriate declarations.
1541 sub lineseq {
1542     my($self, $root, $cx, @ops) = @_;
1543     my($expr, @exprs);
1544
1545     my $out_cop = $self->{'curcop'};
1546     my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1547     my $limit_seq;
1548     if (defined $root) {
1549         $limit_seq = $out_seq;
1550         my $nseq;
1551         $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
1552         $limit_seq = $nseq if !defined($limit_seq)
1553                            or defined($nseq) && $nseq < $limit_seq;
1554     }
1555     $limit_seq = $self->{'limit_seq'}
1556         if defined($self->{'limit_seq'})
1557         && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1558     local $self->{'limit_seq'} = $limit_seq;
1559
1560     $self->walk_lineseq($root, \@ops,
1561                        sub { push @exprs, $_[0]} );
1562
1563     my $sep = $cx ? '; ' : ";\n";
1564     my $body = join($sep, grep {length} @exprs);
1565     my $subs = "";
1566     if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
1567         $subs = join "\n", $self->seq_subs($limit_seq);
1568     }
1569     return join($sep, grep {length} $body, $subs);
1570 }
1571
1572 sub scopeop {
1573     my($real_block, $self, $op, $cx) = @_;
1574     my $kid;
1575     my @kids;
1576
1577     local(@$self{qw'curstash warnings hints hinthash'})
1578                 = @$self{qw'curstash warnings hints hinthash'} if $real_block;
1579     if ($real_block) {
1580         $kid = $op->first->sibling; # skip enter
1581         if (is_miniwhile($kid)) {
1582             my $top = $kid->first;
1583             my $name = $top->name;
1584             if ($name eq "and") {
1585                 $name = $self->keyword("while");
1586             } elsif ($name eq "or") {
1587                 $name = $self->keyword("until");
1588             } else { # no conditional -> while 1 or until 0
1589                 return $self->deparse($top->first, 1) . " "
1590                      . $self->keyword("while") . " 1";
1591             }
1592             my $cond = $top->first;
1593             my $body = $cond->sibling->first; # skip lineseq
1594             $cond = $self->deparse($cond, 1);
1595             $body = $self->deparse($body, 1);
1596             return "$body $name $cond";
1597         }
1598     } else {
1599         $kid = $op->first;
1600     }
1601     for (; !null($kid); $kid = $kid->sibling) {
1602         push @kids, $kid;
1603     }
1604     if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
1605         my $body = $self->lineseq($op, 0, @kids);
1606         return is_lexical_subs(@kids)
1607                 ? $body
1608                 : ($self->lex_in_scope("&do") ? "CORE::do" : "do")
1609                  . " {\n\t$body\n\b}";
1610     } else {
1611         my $lineseq = $self->lineseq($op, $cx, @kids);
1612         return (length ($lineseq) ? "$lineseq;" : "");
1613     }
1614 }
1615
1616 sub pp_scope { scopeop(0, @_); }
1617 sub pp_lineseq { scopeop(0, @_); }
1618 sub pp_leave { scopeop(1, @_); }
1619
1620 # This is a special case of scopeop and lineseq, for the case of the
1621 # main_root. The difference is that we print the output statements as
1622 # soon as we get them, for the sake of impatient users.
1623 sub deparse_root {
1624     my $self = shift;
1625     my($op) = @_;
1626     local(@$self{qw'curstash warnings hints hinthash'})
1627       = @$self{qw'curstash warnings hints hinthash'};
1628     my @kids;
1629     return if null $op->first; # Can happen, e.g., for Bytecode without -k
1630     for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
1631         push @kids, $kid;
1632     }
1633     $self->walk_lineseq($op, \@kids,
1634                         sub { return unless length $_[0];
1635                               print $self->indent($_[0].';');
1636                               print "\n"
1637                                 unless $_[1] == $#kids;
1638                           });
1639 }
1640
1641 sub walk_lineseq {
1642     my ($self, $op, $kids, $callback) = @_;
1643     my @kids = @$kids;
1644     for (my $i = 0; $i < @kids; $i++) {
1645         my $expr = "";
1646         if (is_state $kids[$i]) {
1647             $expr = $self->deparse($kids[$i++], 0);
1648             if ($i > $#kids) {
1649                 $callback->($expr, $i);
1650                 last;
1651             }
1652         }
1653         if (is_for_loop($kids[$i])) {
1654             $callback->($expr . $self->for_loop($kids[$i], 0),
1655                 $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
1656             next;
1657         }
1658         my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2);
1659         $expr2 =~ s/^sub :(?!:)/+sub :/; # statement label otherwise
1660         $expr .= $expr2;
1661         $callback->($expr, $i);
1662     }
1663 }
1664
1665 # The BEGIN {} is used here because otherwise this code isn't executed
1666 # when you run B::Deparse on itself.
1667 my %globalnames;
1668 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1669             "ENV", "ARGV", "ARGVOUT", "_"); }
1670
1671 sub gv_name {
1672     my $self = shift;
1673     my $gv = shift;
1674     my $raw = shift;
1675 #Carp::confess() unless ref($gv) eq "B::GV";
1676     my $cv = $gv->FLAGS & SVf_ROK ? $gv->RV : 0;
1677     my $stash = ($cv || $gv)->STASH->NAME;
1678     my $name = $raw
1679         ? $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME
1680         : $cv
1681             ? B::safename($cv->NAME_HEK || $cv->GV->NAME)
1682             : $gv->SAFENAME;
1683     if ($stash eq 'main' && $name =~ /^::/) {
1684         $stash = '::';
1685     }
1686     elsif (($stash eq 'main'
1687             && ($globalnames{$name} || $name =~ /^[^A-Za-z_:]/))
1688         or ($stash eq $self->{'curstash'} && !$globalnames{$name}
1689             && ($stash eq 'main' || $name !~ /::/))
1690           )
1691     {
1692         $stash = "";
1693     } else {
1694         $stash = $stash . "::";
1695     }
1696     if (!$raw and $name =~ /^(\^..|{)/) {
1697         $name = "{$name}";       # ${^WARNING_BITS}, etc and ${
1698     }
1699     return $stash . $name;
1700 }
1701
1702 # Return the name to use for a stash variable.
1703 # If a lexical with the same name is in scope, or
1704 # if strictures are enabled, it may need to be
1705 # fully-qualified.
1706 sub stash_variable {
1707     my ($self, $prefix, $name, $cx) = @_;
1708
1709     return "$prefix$name" if $name =~ /::/;
1710
1711     unless ($prefix eq '$' || $prefix eq '@' || $prefix eq '&' || #'
1712             $prefix eq '%' || $prefix eq '$#') {
1713         return "$prefix$name";
1714     }
1715
1716     if ($name =~ /^[^[:alpha:]_+-]$/) {
1717       if (defined $cx && $cx == 26) {
1718         if ($prefix eq '@') {
1719             return "$prefix\{$name}";
1720         }
1721         elsif ($name eq '#') { return '${#}' } #  "${#}a" vs "$#a"
1722       }
1723       if ($prefix eq '$#') {
1724         return "\$#{$name}";
1725       }
1726     }
1727
1728     return $prefix . $self->maybe_qualify($prefix, $name);
1729 }
1730
1731 my %unctrl = # portable to EBCDIC
1732     (
1733      "\c@" => '@',      # unused
1734      "\cA" => 'A',
1735      "\cB" => 'B',
1736      "\cC" => 'C',
1737      "\cD" => 'D',
1738      "\cE" => 'E',
1739      "\cF" => 'F',
1740      "\cG" => 'G',
1741      "\cH" => 'H',
1742      "\cI" => 'I',
1743      "\cJ" => 'J',
1744      "\cK" => 'K',
1745      "\cL" => 'L',
1746      "\cM" => 'M',
1747      "\cN" => 'N',
1748      "\cO" => 'O',
1749      "\cP" => 'P',
1750      "\cQ" => 'Q',
1751      "\cR" => 'R',
1752      "\cS" => 'S',
1753      "\cT" => 'T',
1754      "\cU" => 'U',
1755      "\cV" => 'V',
1756      "\cW" => 'W',
1757      "\cX" => 'X',
1758      "\cY" => 'Y',
1759      "\cZ" => 'Z',
1760      "\c[" => '[',      # unused
1761      "\c\\" => '\\',    # unused
1762      "\c]" => ']',      # unused
1763      "\c_" => '_',      # unused
1764     );
1765
1766 # Return just the name, without the prefix.  It may be returned as a quoted
1767 # string.  The second return value is a boolean indicating that.
1768 sub stash_variable_name {
1769     my($self, $prefix, $gv) = @_;
1770     my $name = $self->gv_name($gv, 1);
1771     $name = $self->maybe_qualify($prefix,$name);
1772     if ($name =~ /^(?:\S|(?!\d)[\ca-\cz]?(?:\w|::)*|\d+)\z/) {
1773         $name =~ s/^([\ca-\cz])/'^' . $unctrl{$1}/e;
1774         $name =~ /^(\^..|{)/ and $name = "{$name}";
1775         return $name, 0; # not quoted
1776     }
1777     else {
1778         single_delim("q", "'", $name, $self), 1;
1779     }
1780 }
1781
1782 sub maybe_qualify {
1783     my ($self,$prefix,$name) = @_;
1784     my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1785     return $name if !$prefix || $name =~ /::/;
1786     return $self->{'curstash'}.'::'. $name
1787         if
1788             $name =~ /^(?!\d)\w/         # alphabetic
1789          && $v    !~ /^\$[ab]\z/         # not $a or $b
1790          && !$globalnames{$name}         # not a global name
1791          && $self->{hints} & $strict_bits{vars}  # strict vars
1792          && !$self->lex_in_scope($v,1)   # no "our"
1793       or $self->lex_in_scope($v);        # conflicts with "my" variable
1794     return $name;
1795 }
1796
1797 sub lex_in_scope {
1798     my ($self, $name, $our) = @_;
1799     substr $name, 0, 0, = $our ? 'o' : 'm'; # our/my
1800     $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1801
1802     return 0 if !defined($self->{'curcop'});
1803     my $seq = $self->{'curcop'}->cop_seq;
1804     return 0 if !exists $self->{'curcvlex'}{$name};
1805     for my $a (@{$self->{'curcvlex'}{$name}}) {
1806         my ($st, $en) = @$a;
1807         return 1 if $seq > $st && $seq <= $en;
1808     }
1809     return 0;
1810 }
1811
1812 sub populate_curcvlex {
1813     my $self = shift;
1814     for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1815         my $padlist = $cv->PADLIST;
1816         # an undef CV still in lexical chain
1817         next if class($padlist) eq "SPECIAL";
1818         my @padlist = $padlist->ARRAY;
1819         my @ns = $padlist[0]->ARRAY;
1820
1821         for (my $i=0; $i<@ns; ++$i) {
1822             next if class($ns[$i]) eq "SPECIAL";
1823             if (class($ns[$i]) eq "PV") {
1824                 # Probably that pesky lexical @_
1825                 next;
1826             }
1827             my $name = $ns[$i]->PVX;
1828             next unless defined $name;
1829             my ($seq_st, $seq_en) =
1830                 ($ns[$i]->FLAGS & SVf_FAKE)
1831                     ? (0, 999999)
1832                     : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH);
1833
1834             push @{$self->{'curcvlex'}{
1835                         ($ns[$i]->FLAGS & SVpad_OUR ? 'o' : 'm') . $name
1836                   }}, [$seq_st, $seq_en, $ns[$i]];
1837         }
1838     }
1839 }
1840
1841 sub find_scope_st { ((find_scope(@_))[0]); }
1842 sub find_scope_en { ((find_scope(@_))[1]); }
1843
1844 # Recurses down the tree, looking for pad variable introductions and COPs
1845 sub find_scope {
1846     my ($self, $op, $scope_st, $scope_en) = @_;
1847     carp("Undefined op in find_scope") if !defined $op;
1848     return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1849
1850     my @queue = ($op);
1851     while(my $op = shift @queue ) {
1852         for (my $o=$op->first; $$o; $o=$o->sibling) {
1853             if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1854                 my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW);
1855                 my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH;
1856                 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1857                 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1858                 return ($scope_st, $scope_en);
1859             }
1860             elsif (is_state($o)) {
1861                 my $c = $o->cop_seq;
1862                 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1863                 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1864                 return ($scope_st, $scope_en);
1865             }
1866             elsif ($o->flags & OPf_KIDS) {
1867                 unshift (@queue, $o);
1868             }
1869         }
1870     }
1871
1872     return ($scope_st, $scope_en);
1873 }
1874
1875 # Returns a list of subs which should be inserted before the COP
1876 sub cop_subs {
1877     my ($self, $op, $out_seq) = @_;
1878     my $seq = $op->cop_seq;
1879     if ($] < 5.021006) {
1880       # If we have nephews, then our sequence number indicates
1881       # the cop_seq of the end of some sort of scope.
1882       if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1883         and my $nseq = $self->find_scope_st($op->sibling) ) {
1884         $seq = $nseq;
1885       }
1886     }
1887     $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1888     return $self->seq_subs($seq);
1889 }
1890
1891 sub seq_subs {
1892     my ($self, $seq) = @_;
1893     my @text;
1894 #push @text, "# ($seq)\n";
1895
1896     return "" if !defined $seq;
1897     my @pending;
1898     while (scalar(@{$self->{'subs_todo'}})
1899            and $seq > $self->{'subs_todo'}[0][0]) {
1900         my $cv = $self->{'subs_todo'}[0][1];
1901         # Skip the OUTSIDE check for lexical subs.  We may be deparsing a
1902         # cloned anon sub with lexical subs declared in it, in which case
1903         # the OUTSIDE pointer points to the anon protosub.
1904         my $lexical = ref $self->{'subs_todo'}[0][3];
1905         my $outside = !$lexical && $cv && $cv->OUTSIDE;
1906         if (!$lexical and $cv
1907          and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}})
1908         {
1909             push @pending, shift @{$self->{'subs_todo'}};
1910             next;
1911         }
1912         push @text, $self->next_todo;
1913     }
1914     unshift @{$self->{'subs_todo'}}, @pending;
1915     return @text;
1916 }
1917
1918 sub _features_from_bundle {
1919     my ($hints, $hh) = @_;
1920     foreach (@{$feature::feature_bundle{@feature::hint_bundles[$hints >> $feature::hint_shift]}}) {
1921         $hh->{$feature::feature{$_}} = 1;
1922     }
1923     return $hh;
1924 }
1925
1926 # generate any pragmas, 'package foo' etc needed to synchronise
1927 # with the given cop
1928
1929 sub pragmata {
1930     my $self = shift;
1931     my($op) = @_;
1932
1933     my @text;
1934
1935     my $stash = $op->stashpv;
1936     if ($stash ne $self->{'curstash'}) {
1937         push @text, $self->keyword("package") . " $stash;\n";
1938         $self->{'curstash'} = $stash;
1939     }
1940
1941     if (OPpCONST_ARYBASE && $self->{'arybase'} != $op->arybase) {
1942         push @text, '$[ = '. $op->arybase .";\n";
1943         $self->{'arybase'} = $op->arybase;
1944     }
1945
1946     my $warnings = $op->warnings;
1947     my $warning_bits;
1948     if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1949         $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
1950     }
1951     elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1952         $warning_bits = $warnings::NONE;
1953     }
1954     elsif ($warnings->isa("B::SPECIAL")) {
1955         $warning_bits = undef;
1956     }
1957     else {
1958         $warning_bits = $warnings->PV & WARN_MASK;
1959     }
1960
1961     if (defined ($warning_bits) and
1962        !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1963         push @text,
1964             $self->declare_warnings($self->{'warnings'}, $warning_bits);
1965         $self->{'warnings'} = $warning_bits;
1966     }
1967
1968     my $hints = $] < 5.008009 ? $op->private : $op->hints;
1969     my $old_hints = $self->{'hints'};
1970     if ($self->{'hints'} != $hints) {
1971         push @text, $self->declare_hints($self->{'hints'}, $hints);
1972         $self->{'hints'} = $hints;
1973     }
1974
1975     my $newhh;
1976     if ($] > 5.009) {
1977         $newhh = $op->hints_hash->HASH;
1978     }
1979
1980     if ($] >= 5.015006) {
1981         # feature bundle hints
1982         my $from = $old_hints & $feature::hint_mask;
1983         my $to   = $    hints & $feature::hint_mask;
1984         if ($from != $to) {
1985             if ($to == $feature::hint_mask) {
1986                 if ($self->{'hinthash'}) {
1987                     delete $self->{'hinthash'}{$_}
1988                         for grep /^feature_/, keys %{$self->{'hinthash'}};
1989                 }
1990                 else { $self->{'hinthash'} = {} }
1991                 $self->{'hinthash'}
1992                     = _features_from_bundle($from, $self->{'hinthash'});
1993             }
1994             else {
1995                 my $bundle =
1996                     $feature::hint_bundles[$to >> $feature::hint_shift];
1997                 $bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12
1998                 push @text,
1999                     $self->keyword("no") . " feature ':all';\n",
2000                     $self->keyword("use") . " feature ':$bundle';\n";
2001             }
2002         }
2003     }
2004
2005     if ($] > 5.009) {
2006         push @text, $self->declare_hinthash(
2007             $self->{'hinthash'}, $newhh,
2008             $self->{indent_size}, $self->{hints},
2009         );
2010         $self->{'hinthash'} = $newhh;
2011     }
2012
2013     return join("", @text);
2014 }
2015
2016
2017 # Notice how subs and formats are inserted between statements here;
2018 # also $[ assignments and pragmas.
2019 sub pp_nextstate {
2020     my $self = shift;
2021     my($op, $cx) = @_;
2022     $self->{'curcop'} = $op;
2023
2024     my @text;
2025
2026     my @subs = $self->cop_subs($op);
2027     if (@subs) {
2028         # Special marker to swallow up the semicolon
2029         push @subs, "\cK";
2030     }
2031     push @text, @subs;
2032
2033     push @text, $self->pragmata($op);
2034
2035
2036     # This should go after of any branches that add statements, to
2037     # increase the chances that it refers to the same line it did in
2038     # the original program.
2039     if ($self->{'linenums'} && $cx != .5) { # $cx == .5 means in a format
2040         push @text, "\f#line " . $op->line .
2041           ' "' . $op->file, qq'"\n';
2042     }
2043
2044     push @text, $op->label . ": " if $op->label;
2045
2046     return join("", @text);
2047 }
2048
2049 sub declare_warnings {
2050     my ($self, $from, $to) = @_;
2051     if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
2052         return $self->keyword("use") . " warnings;\n";
2053     }
2054     elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
2055         return $self->keyword("no") . " warnings;\n";
2056     }
2057     return "BEGIN {\${^WARNING_BITS} = \""
2058            . join("", map { sprintf("\\x%02x", ord $_) } split "", $to)
2059            . "\"}\n\cK";
2060 }
2061
2062 sub declare_hints {
2063     my ($self, $from, $to) = @_;
2064     my $use = $to   & ~$from;
2065     my $no  = $from & ~$to;
2066     my $decls = "";
2067     for my $pragma (hint_pragmas($use)) {
2068         $decls .= $self->keyword("use") . " $pragma;\n";
2069     }
2070     for my $pragma (hint_pragmas($no)) {
2071         $decls .= $self->keyword("no") . " $pragma;\n";
2072     }
2073     return $decls;
2074 }
2075
2076 # Internal implementation hints that the core sets automatically, so don't need
2077 # (or want) to be passed back to the user
2078 my %ignored_hints = (
2079     'open<' => 1,
2080     'open>' => 1,
2081     ':'     => 1,
2082     'strict/refs' => 1,
2083     'strict/subs' => 1,
2084     'strict/vars' => 1,
2085 );
2086
2087 my %rev_feature;
2088
2089 sub declare_hinthash {
2090     my ($self, $from, $to, $indent, $hints) = @_;
2091     my $doing_features =
2092         ($hints & $feature::hint_mask) == $feature::hint_mask;
2093     my @decls;
2094     my @features;
2095     my @unfeatures; # bugs?
2096     for my $key (sort keys %$to) {
2097         next if $ignored_hints{$key};
2098         my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6;
2099         next if $is_feature and not $doing_features;
2100         if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) {
2101             push(@features, $key), next if $is_feature;
2102             push @decls,
2103                 qq(\$^H{) . single_delim("q", "'", $key, $self) . qq(} = )
2104               . (
2105                    defined $to->{$key}
2106                         ? single_delim("q", "'", $to->{$key}, $self)
2107                         : 'undef'
2108                 )
2109               . qq(;);
2110         }
2111     }
2112     for my $key (sort keys %$from) {
2113         next if $ignored_hints{$key};
2114         my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6;
2115         next if $is_feature and not $doing_features;
2116         if (!exists $to->{$key}) {
2117             push(@unfeatures, $key), next if $is_feature;
2118             push @decls, qq(delete \$^H{'$key'};);
2119         }
2120     }
2121     my @ret;
2122     if (@features || @unfeatures) {
2123         if (!%rev_feature) { %rev_feature = reverse %feature::feature }
2124     }
2125     if (@features) {
2126         push @ret, $self->keyword("use") . " feature "
2127                  . join(", ", map "'$rev_feature{$_}'", @features) . ";\n";
2128     }
2129     if (@unfeatures) {
2130         push @ret, $self->keyword("no") . " feature "
2131                  . join(", ", map "'$rev_feature{$_}'", @unfeatures)
2132                  . ";\n";
2133     }
2134     @decls and
2135         push @ret,
2136              join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n\cK";
2137     return @ret;
2138 }
2139
2140 sub hint_pragmas {
2141     my ($bits) = @_;
2142     my (@pragmas, @strict);
2143     push @pragmas, "integer" if $bits & 0x1;
2144     for (sort keys %strict_bits) {
2145         push @strict, "'$_'" if $bits & $strict_bits{$_};
2146     }
2147     if (@strict == keys %strict_bits) {
2148         push @pragmas, "strict";
2149     }
2150     elsif (@strict) {
2151         push @pragmas, "strict " . join ', ', @strict;
2152     }
2153     push @pragmas, "bytes" if $bits & 0x8;
2154     return @pragmas;
2155 }
2156
2157 sub pp_dbstate { pp_nextstate(@_) }
2158 sub pp_setstate { pp_nextstate(@_) }
2159
2160 sub pp_unstack { return "" } # see also leaveloop
2161
2162 my %feature_keywords = (
2163   # keyword => 'feature',
2164     state   => 'state',
2165     say     => 'say',
2166     given   => 'switch',
2167     when    => 'switch',
2168     default => 'switch',
2169     break   => 'switch',
2170     evalbytes=>'evalbytes',
2171     __SUB__ => '__SUB__',
2172    fc       => 'fc',
2173 );
2174
2175 # keywords that are strong and also have a prototype
2176 #
2177 my %strong_proto_keywords = map { $_ => 1 } qw(
2178     pos
2179     prototype
2180     scalar
2181     study
2182     undef
2183 );
2184
2185 sub feature_enabled {
2186         my($self,$name) = @_;
2187         my $hh;
2188         my $hints = $self->{hints} & $feature::hint_mask;
2189         if ($hints && $hints != $feature::hint_mask) {
2190             $hh = _features_from_bundle($hints);
2191         }
2192         elsif ($hints) { $hh = $self->{'hinthash'} }
2193         return $hh && $hh->{"feature_$feature_keywords{$name}"}
2194 }
2195
2196 sub keyword {
2197     my $self = shift;
2198     my $name = shift;
2199     return $name if $name =~ /^CORE::/; # just in case
2200     if (exists $feature_keywords{$name}) {
2201         return "CORE::$name" if not $self->feature_enabled($name);
2202     }
2203     # This sub may be called for a program that has no nextstate ops.  In
2204     # that case we may have a lexical sub named no/use/sub in scope but
2205     # but $self->lex_in_scope will return false because it depends on the
2206     # current nextstate op.  So we need this alternate method if there is
2207     # no current cop.
2208     if (!$self->{'curcop'}) {
2209         $self->populate_curcvlex() if !defined $self->{'curcvlex'};
2210         return "CORE::$name" if exists $self->{'curcvlex'}{"m&$name"}
2211                              || exists $self->{'curcvlex'}{"o&$name"};
2212     } elsif ($self->lex_in_scope("&$name")
2213           || $self->lex_in_scope("&$name", 1)) {
2214         return "CORE::$name";
2215     }
2216     if ($strong_proto_keywords{$name}
2217         || ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
2218             && !defined eval{prototype "CORE::$name"})
2219     ) { return $name }
2220     if (
2221         exists $self->{subs_declared}{$name}
2222          or
2223         exists &{"$self->{curstash}::$name"}
2224     ) {
2225         return "CORE::$name"
2226     }
2227     return $name;
2228 }
2229
2230 sub baseop {
2231     my $self = shift;
2232     my($op, $cx, $name) = @_;
2233     return $self->keyword($name);
2234 }
2235
2236 sub pp_stub { "()" }
2237 sub pp_wantarray { baseop(@_, "wantarray") }
2238 sub pp_fork { baseop(@_, "fork") }
2239 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
2240 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
2241 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
2242 sub pp_tms { baseop(@_, "times") }
2243 sub pp_ghostent { baseop(@_, "gethostent") }
2244 sub pp_gnetent { baseop(@_, "getnetent") }
2245 sub pp_gprotoent { baseop(@_, "getprotoent") }
2246 sub pp_gservent { baseop(@_, "getservent") }
2247 sub pp_ehostent { baseop(@_, "endhostent") }
2248 sub pp_enetent { baseop(@_, "endnetent") }
2249 sub pp_eprotoent { baseop(@_, "endprotoent") }
2250 sub pp_eservent { baseop(@_, "endservent") }
2251 sub pp_gpwent { baseop(@_, "getpwent") }
2252 sub pp_spwent { baseop(@_, "setpwent") }
2253 sub pp_epwent { baseop(@_, "endpwent") }
2254 sub pp_ggrent { baseop(@_, "getgrent") }
2255 sub pp_sgrent { baseop(@_, "setgrent") }
2256 sub pp_egrent { baseop(@_, "endgrent") }
2257 sub pp_getlogin { baseop(@_, "getlogin") }
2258
2259 sub POSTFIX () { 1 }
2260
2261 # I couldn't think of a good short name, but this is the category of
2262 # symbolic unary operators with interesting precedence
2263
2264 sub pfixop {
2265     my $self = shift;
2266     my($op, $cx, $name, $prec, $flags) = (@_, 0);
2267     my $kid = $op->first;
2268     $kid = $self->deparse($kid, $prec);
2269     return $self->maybe_parens(($flags & POSTFIX)
2270                                  ? "$kid$name"
2271                                    # avoid confusion with filetests
2272                                  : $name eq '-'
2273                                    && $kid =~ /^[a-zA-Z](?!\w)/
2274                                         ? "$name($kid)"
2275                                         : "$name$kid",
2276                                $cx, $prec);
2277 }
2278
2279 sub pp_preinc { pfixop(@_, "++", 23) }
2280 sub pp_predec { pfixop(@_, "--", 23) }
2281 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
2282 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
2283 sub pp_i_preinc { pfixop(@_, "++", 23) }
2284 sub pp_i_predec { pfixop(@_, "--", 23) }
2285 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
2286 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
2287 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
2288 *pp_ncomplement = *pp_complement;
2289 sub pp_scomplement { maybe_targmy(@_, \&pfixop, "~.", 21) }
2290
2291 sub pp_negate { maybe_targmy(@_, \&real_negate) }
2292 sub real_negate {
2293     my $self = shift;
2294     my($op, $cx) = @_;
2295     if ($op->first->name =~ /^(i_)?negate$/) {
2296         # avoid --$x
2297         $self->pfixop($op, $cx, "-", 21.5);
2298     } else {
2299         $self->pfixop($op, $cx, "-", 21);       
2300     }
2301 }
2302 sub pp_i_negate { pp_negate(@_) }
2303
2304 sub pp_not {
2305     my $self = shift;
2306     my($op, $cx) = @_;
2307     if ($cx <= 4) {
2308         $self->listop($op, $cx, "not", $op->first);
2309     } else {
2310         $self->pfixop($op, $cx, "!", 21);       
2311     }
2312 }
2313
2314 sub unop {
2315     my $self = shift;
2316     my($op, $cx, $name, $nollafr) = @_;
2317     my $kid;
2318     if ($op->flags & OPf_KIDS) {
2319         $kid = $op->first;
2320         if (not $name) {
2321             # this deals with 'boolkeys' right now
2322             return $self->deparse($kid,$cx);
2323         }
2324         my $builtinname = $name;
2325         $builtinname =~ /^CORE::/ or $builtinname = "CORE::$name";
2326         if (defined prototype($builtinname)
2327            && $builtinname ne 'CORE::readline'
2328            && prototype($builtinname) =~ /^;?\*/
2329            && $kid->name eq "rv2gv") {
2330             $kid = $kid->first;
2331         }
2332
2333         if ($nollafr) {
2334             if (($kid = $self->deparse($kid, 16)) !~ s/^\cS//) {
2335                 # require foo() is a syntax error.
2336                 $kid =~ /^(?!\d)\w/ and $kid = "($kid)";
2337             }
2338             return $self->maybe_parens(
2339                         $self->keyword($name) . " $kid", $cx, 16
2340                    );
2341         }   
2342         return $self->maybe_parens_unop($name, $kid, $cx);
2343     } else {
2344         return $self->maybe_parens(
2345             $self->keyword($name) . ($op->flags & OPf_SPECIAL ? "()" : ""),
2346             $cx, 16,
2347         );
2348     }
2349 }
2350
2351 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
2352 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
2353 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
2354 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
2355 sub pp_defined { unop(@_, "defined") }
2356 sub pp_undef { unop(@_, "undef") }
2357 sub pp_study { unop(@_, "study") }
2358 sub pp_ref { unop(@_, "ref") }
2359 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
2360
2361 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
2362 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
2363 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
2364 sub pp_srand { unop(@_, "srand") }
2365 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
2366 sub pp_log { maybe_targmy(@_, \&unop, "log") }
2367 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
2368 sub pp_int { maybe_targmy(@_, \&unop, "int") }
2369 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
2370 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
2371 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
2372
2373 sub pp_length { maybe_targmy(@_, \&unop, "length") }
2374 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
2375 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
2376
2377 sub pp_each { unop(@_, "each") }
2378 sub pp_values { unop(@_, "values") }
2379 sub pp_keys { unop(@_, "keys") }
2380 { no strict 'refs'; *{"pp_r$_"} = *{"pp_$_"} for qw< keys each values >; }
2381 sub pp_boolkeys { 
2382     # no name because its an optimisation op that has no keyword
2383     unop(@_,"");
2384 }
2385 sub pp_aeach { unop(@_, "each") }
2386 sub pp_avalues { unop(@_, "values") }
2387 sub pp_akeys { unop(@_, "keys") }
2388 sub pp_pop { unop(@_, "pop") }
2389 sub pp_shift { unop(@_, "shift") }
2390
2391 sub pp_caller { unop(@_, "caller") }
2392 sub pp_reset { unop(@_, "reset") }
2393 sub pp_exit { unop(@_, "exit") }
2394 sub pp_prototype { unop(@_, "prototype") }
2395
2396 sub pp_close { unop(@_, "close") }
2397 sub pp_fileno { unop(@_, "fileno") }
2398 sub pp_umask { unop(@_, "umask") }
2399 sub pp_untie { unop(@_, "untie") }
2400 sub pp_tied { unop(@_, "tied") }
2401 sub pp_dbmclose { unop(@_, "dbmclose") }
2402 sub pp_getc { unop(@_, "getc") }
2403 sub pp_eof { unop(@_, "eof") }
2404 sub pp_tell { unop(@_, "tell") }
2405 sub pp_getsockname { unop(@_, "getsockname") }
2406 sub pp_getpeername { unop(@_, "getpeername") }
2407
2408 sub pp_chdir {
2409     my ($self, $op, $cx) = @_;
2410     if (($op->flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS)) {
2411         my $kw = $self->keyword("chdir");
2412         my $kid = $self->const_sv($op->first)->PV;
2413         my $code = $kw
2414                  . ($cx >= 16 || $self->{'parens'} ? "($kid)" : " $kid");
2415         maybe_targmy(@_, sub { $_[3] }, $code);
2416     } else {
2417         maybe_targmy(@_, \&unop, "chdir")
2418     }
2419 }
2420
2421 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
2422 sub pp_readlink { unop(@_, "readlink") }
2423 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
2424 sub pp_readdir { unop(@_, "readdir") }
2425 sub pp_telldir { unop(@_, "telldir") }
2426 sub pp_rewinddir { unop(@_, "rewinddir") }
2427 sub pp_closedir { unop(@_, "closedir") }
2428 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
2429 sub pp_localtime { unop(@_, "localtime") }
2430 sub pp_gmtime { unop(@_, "gmtime") }
2431 sub pp_alarm { unop(@_, "alarm") }
2432 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
2433
2434 sub pp_dofile {
2435     my $code = unop(@_, "do", 1); # llafr does not apply
2436     if ($code =~ s/^((?:CORE::)?do) \{/$1({/) { $code .= ')' }
2437     $code;
2438 }
2439 sub pp_entereval {
2440     unop(
2441       @_,
2442       $_[1]->private & OPpEVAL_BYTES ? 'evalbytes' : "eval"
2443     )
2444 }
2445
2446 sub pp_ghbyname { unop(@_, "gethostbyname") }
2447 sub pp_gnbyname { unop(@_, "getnetbyname") }
2448 sub pp_gpbyname { unop(@_, "getprotobyname") }
2449 sub pp_shostent { unop(@_, "sethostent") }
2450 sub pp_snetent { unop(@_, "setnetent") }
2451 sub pp_sprotoent { unop(@_, "setprotoent") }
2452 sub pp_sservent { unop(@_, "setservent") }
2453 sub pp_gpwnam { unop(@_, "getpwnam") }
2454 sub pp_gpwuid { unop(@_, "getpwuid") }
2455 sub pp_ggrnam { unop(@_, "getgrnam") }
2456 sub pp_ggrgid { unop(@_, "getgrgid") }
2457
2458 sub pp_lock { unop(@_, "lock") }
2459
2460 sub pp_continue { unop(@_, "continue"); }
2461 sub pp_break { unop(@_, "break"); }
2462
2463 sub givwhen {
2464     my $self = shift;
2465     my($op, $cx, $givwhen) = @_;
2466
2467     my $enterop = $op->first;
2468     my ($head, $block);
2469     if ($enterop->flags & OPf_SPECIAL) {
2470         $head = $self->keyword("default");
2471         $block = $self->deparse($enterop->first, 0);
2472     }
2473     else {
2474         my $cond = $enterop->first;
2475         my $cond_str = $self->deparse($cond, 1);
2476         $head = "$givwhen ($cond_str)";
2477         $block = $self->deparse($cond->sibling, 0);
2478     }
2479
2480     return "$head {\n".
2481         "\t$block\n".
2482         "\b}\cK";
2483 }
2484
2485 sub pp_leavegiven { givwhen(@_, $_[0]->keyword("given")); }
2486 sub pp_leavewhen  { givwhen(@_, $_[0]->keyword("when")); }
2487
2488 sub pp_exists {
2489     my $self = shift;
2490     my($op, $cx) = @_;
2491     my $arg;
2492     my $name = $self->keyword("exists");
2493     if ($op->private & OPpEXISTS_SUB) {
2494         # Checking for the existence of a subroutine
2495         return $self->maybe_parens_func($name,
2496                                 $self->pp_rv2cv($op->first, 16), $cx, 16);
2497     }
2498     if ($op->flags & OPf_SPECIAL) {
2499         # Array element, not hash element
2500         return $self->maybe_parens_func($name,
2501                                 $self->pp_aelem($op->first, 16), $cx, 16);
2502     }
2503     return $self->maybe_parens_func($name, $self->pp_helem($op->first, 16),
2504                                     $cx, 16);
2505 }
2506
2507 sub pp_delete {
2508     my $self = shift;
2509     my($op, $cx) = @_;
2510     my $arg;
2511     my $name = $self->keyword("delete");
2512     if ($op->private & OPpSLICE) {
2513         if ($op->flags & OPf_SPECIAL) {
2514             # Deleting from an array, not a hash
2515             return $self->maybe_parens_func($name,
2516                                         $self->pp_aslice($op->first, 16),
2517                                         $cx, 16);
2518         }
2519         return $self->maybe_parens_func($name,
2520                                         $self->pp_hslice($op->first, 16),
2521                                         $cx, 16);
2522     } else {
2523         if ($op->flags & OPf_SPECIAL) {
2524             # Deleting from an array, not a hash
2525             return $self->maybe_parens_func($name,
2526                                         $self->pp_aelem($op->first, 16),
2527                                         $cx, 16);
2528         }
2529         return $self->maybe_parens_func($name,
2530                                         $self->pp_helem($op->first, 16),
2531                                         $cx, 16);
2532     }
2533 }
2534
2535 sub pp_require {
2536     my $self = shift;
2537     my($op, $cx) = @_;
2538     my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
2539     my $kid = $op->first;
2540     if ($kid->name eq 'const') {
2541         my $priv = $kid->private;
2542         my $sv = $self->const_sv($kid);
2543         my $arg;
2544         if ($priv & OPpCONST_BARE) {
2545             $arg = $sv->PV;
2546             $arg =~ s[/][::]g;
2547             $arg =~ s/\.pm//g;
2548         } elsif ($priv & OPpCONST_NOVER) {
2549             $opname = $self->keyword('no');
2550             $arg = $self->const($sv, 16);
2551         } elsif ((my $tmp = $self->const($sv, 16)) =~ /^v/) {
2552             $arg = $tmp;
2553         }
2554         if ($arg) {
2555             return $self->maybe_parens("$opname $arg", $cx, 16);
2556         }
2557     }
2558     $self->unop(
2559             $op, $cx,
2560             $opname,
2561             1, # llafr does not apply
2562     );
2563 }
2564
2565 sub pp_scalar {
2566     my $self = shift;
2567     my($op, $cx) = @_;
2568     my $kid = $op->first;
2569     if (not null $kid->sibling) {
2570         # XXX Was a here-doc
2571         return $self->dquote($op);
2572     }
2573     $self->unop(@_, "scalar");
2574 }
2575
2576
2577 sub padval {
2578     my $self = shift;
2579     my $targ = shift;
2580     return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
2581 }
2582
2583 sub anon_hash_or_list {
2584     my $self = shift;
2585     my($op, $cx) = @_;
2586
2587     my($pre, $post) = @{{"anonlist" => ["[","]"],
2588                          "anonhash" => ["{","}"]}->{$op->name}};
2589     my($expr, @exprs);
2590     $op = $op->first->sibling; # skip pushmark
2591     for (; !null($op); $op = $op->sibling) {
2592         $expr = $self->deparse($op, 6);
2593         push @exprs, $expr;
2594     }
2595     if ($pre eq "{" and $cx < 1) {
2596         # Disambiguate that it's not a block
2597         $pre = "+{";
2598     }
2599     return $pre . join(", ", @exprs) . $post;
2600 }
2601
2602 sub pp_anonlist {
2603     my $self = shift;
2604     my ($op, $cx) = @_;
2605     if ($op->flags & OPf_SPECIAL) {
2606         return $self->anon_hash_or_list($op, $cx);
2607     }
2608     warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL";
2609     return 'XXX';
2610 }
2611
2612 *pp_anonhash = \&pp_anonlist;
2613
2614 sub pp_refgen {
2615     my $self = shift;   
2616     my($op, $cx) = @_;
2617     my $kid = $op->first;
2618     if ($kid->name eq "null") {
2619         my $anoncode = $kid = $kid->first;
2620         if ($anoncode->name eq "anonconst") {
2621             $anoncode = $anoncode->first->first->sibling;
2622         }
2623         if ($anoncode->name eq "anoncode"
2624          or !null($anoncode = $kid->sibling) and
2625                  $anoncode->name eq "anoncode") {
2626             return $self->e_anoncode({ code => $self->padval($anoncode->targ) });
2627         } elsif ($kid->name eq "pushmark") {
2628             my $sib_name = $kid->sibling->name;
2629             if ($sib_name eq 'entersub') {
2630                 my $text = $self->deparse($kid->sibling, 1);
2631                 # Always show parens for \(&func()), but only with -p otherwise
2632                 $text = "($text)" if $self->{'parens'}
2633                                  or $kid->sibling->private & OPpENTERSUB_AMPER;
2634                 return "\\$text";
2635             }
2636         }
2637     }
2638     local $self->{'in_refgen'} = 1;
2639     $self->pfixop($op, $cx, "\\", 20);
2640 }
2641
2642 sub e_anoncode {
2643     my ($self, $info) = @_;
2644     my $text = $self->deparse_sub($info->{code});
2645     return $self->keyword("sub") . " $text";
2646 }
2647
2648 sub pp_srefgen { pp_refgen(@_) }
2649
2650 sub pp_readline {
2651     my $self = shift;
2652     my($op, $cx) = @_;
2653     my $kid = $op->first;
2654     if (is_scalar($kid)
2655         and $op->flags & OPf_SPECIAL
2656         and $self->deparse($kid, 1) eq 'ARGV')
2657     {
2658         return '<<>>';
2659     }
2660     return $self->unop($op, $cx, "readline");
2661 }
2662
2663 sub pp_rcatline {
2664     my $self = shift;
2665     my($op) = @_;
2666     return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
2667 }
2668
2669 # Unary operators that can occur as pseudo-listops inside double quotes
2670 sub dq_unop {
2671     my $self = shift;
2672     my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
2673     my $kid;
2674     if ($op->flags & OPf_KIDS) {
2675        $kid = $op->first;
2676        # If there's more than one kid, the first is an ex-pushmark.
2677        $kid = $kid->sibling if not null $kid->sibling;
2678        return $self->maybe_parens_unop($name, $kid, $cx);
2679     } else {
2680        return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");
2681     }
2682 }
2683
2684 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
2685 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
2686 sub pp_uc { dq_unop(@_, "uc") }
2687 sub pp_lc { dq_unop(@_, "lc") }
2688 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
2689 sub pp_fc { dq_unop(@_, "fc") }
2690
2691 sub loopex {
2692     my $self = shift;
2693     my ($op, $cx, $name) = @_;
2694     if (class($op) eq "PVOP") {
2695         $name .= " " . $op->pv;
2696     } elsif (class($op) eq "OP") {
2697         # no-op
2698     } elsif (class($op) eq "UNOP") {
2699         (my $kid = $self->deparse($op->first, 7)) =~ s/^\cS//;
2700         # last foo() is a syntax error.
2701         $kid =~ /^(?!\d)\w/ and $kid = "($kid)";
2702         $name .= " $kid";
2703     }
2704     return $self->maybe_parens($name, $cx, 7);
2705 }
2706
2707 sub pp_last { loopex(@_, "last") }
2708 sub pp_next { loopex(@_, "next") }
2709 sub pp_redo { loopex(@_, "redo") }
2710 sub pp_goto { loopex(@_, "goto") }
2711 sub pp_dump { loopex(@_, "CORE::dump") }
2712
2713 sub ftst {
2714     my $self = shift;
2715     my($op, $cx, $name) = @_;
2716     if (class($op) eq "UNOP") {
2717         # Genuine '-X' filetests are exempt from the LLAFR, but not
2718         # l?stat()
2719         if ($name =~ /^-/) {
2720             (my $kid = $self->deparse($op->first, 16)) =~ s/^\cS//;
2721             return $self->maybe_parens("$name $kid", $cx, 16);
2722         }
2723         return $self->maybe_parens_unop($name, $op->first, $cx);
2724     } elsif (class($op) =~ /^(SV|PAD)OP$/) {
2725         return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
2726     } else { # I don't think baseop filetests ever survive ck_ftst, but...
2727         return $name;
2728     }
2729 }
2730
2731 sub pp_lstat    { ftst(@_, "lstat") }
2732 sub pp_stat     { ftst(@_, "stat") }
2733 sub pp_ftrread  { ftst(@_, "-R") }
2734 sub pp_ftrwrite { ftst(@_, "-W") }
2735 sub pp_ftrexec  { ftst(@_, "-X") }
2736 sub pp_fteread  { ftst(@_, "-r") }
2737 sub pp_ftewrite { ftst(@_, "-w") }
2738 sub pp_fteexec  { ftst(@_, "-x") }
2739 sub pp_ftis     { ftst(@_, "-e") }
2740 sub pp_fteowned { ftst(@_, "-O") }
2741 sub pp_ftrowned { ftst(@_, "-o") }
2742 sub pp_ftzero   { ftst(@_, "-z") }
2743 sub pp_ftsize   { ftst(@_, "-s") }
2744 sub pp_ftmtime  { ftst(@_, "-M") }
2745 sub pp_ftatime  { ftst(@_, "-A") }
2746 sub pp_ftctime  { ftst(@_, "-C") }
2747 sub pp_ftsock   { ftst(@_, "-S") }
2748 sub pp_ftchr    { ftst(@_, "-c") }
2749 sub pp_ftblk    { ftst(@_, "-b") }
2750 sub pp_ftfile   { ftst(@_, "-f") }
2751 sub pp_ftdir    { ftst(@_, "-d") }
2752 sub pp_ftpipe   { ftst(@_, "-p") }
2753 sub pp_ftlink   { ftst(@_, "-l") }
2754 sub pp_ftsuid   { ftst(@_, "-u") }
2755 sub pp_ftsgid   { ftst(@_, "-g") }
2756 sub pp_ftsvtx   { ftst(@_, "-k") }
2757 sub pp_fttty    { ftst(@_, "-t") }
2758 sub pp_fttext   { ftst(@_, "-T") }
2759 sub pp_ftbinary { ftst(@_, "-B") }
2760
2761 sub SWAP_CHILDREN () { 1 }
2762 sub ASSIGN () { 2 } # has OP= variant
2763 sub LIST_CONTEXT () { 4 } # Assignment is in list context
2764
2765 my(%left, %right);
2766
2767 sub assoc_class {
2768     my $op = shift;
2769     my $name = $op->name;
2770     if ($name eq "concat" and $op->first->name eq "concat") {
2771         # avoid spurious '=' -- see comment in pp_concat
2772         return "concat";
2773     }
2774     if ($name eq "null" and class($op) eq "UNOP"
2775         and $op->first->name =~ /^(and|x?or)$/
2776         and null $op->first->sibling)
2777     {
2778         # Like all conditional constructs, OP_ANDs and OP_ORs are topped
2779         # with a null that's used as the common end point of the two
2780         # flows of control. For precedence purposes, ignore it.
2781         # (COND_EXPRs have these too, but we don't bother with
2782         # their associativity).
2783         return assoc_class($op->first);
2784     }
2785     return $name . ($op->flags & OPf_STACKED ? "=" : "");
2786 }
2787
2788 # Left associative operators, like '+', for which
2789 # $a + $b + $c is equivalent to ($a + $b) + $c
2790
2791 BEGIN {
2792     %left = ('multiply' => 19, 'i_multiply' => 19,
2793              'divide' => 19, 'i_divide' => 19,
2794              'modulo' => 19, 'i_modulo' => 19,
2795              'repeat' => 19,
2796              'add' => 18, 'i_add' => 18,
2797              'subtract' => 18, 'i_subtract' => 18,
2798              'concat' => 18,
2799              'left_shift' => 17, 'right_shift' => 17,
2800              'bit_and' => 13, 'nbit_and' => 13, 'sbit_and' => 13,
2801              'bit_or' => 12, 'bit_xor' => 12,
2802              'sbit_or' => 12, 'sbit_xor' => 12,
2803              'nbit_or' => 12, 'nbit_xor' => 12,
2804              'and' => 3,
2805              'or' => 2, 'xor' => 2,
2806             );
2807 }
2808
2809 sub deparse_binop_left {
2810     my $self = shift;
2811     my($op, $left, $prec) = @_;
2812     if ($left{assoc_class($op)} && $left{assoc_class($left)}
2813         and $left{assoc_class($op)} == $left{assoc_class($left)})
2814     {
2815         return $self->deparse($left, $prec - .00001);
2816     } else {
2817         return $self->deparse($left, $prec);    
2818     }
2819 }
2820
2821 # Right associative operators, like '=', for which
2822 # $a = $b = $c is equivalent to $a = ($b = $c)
2823
2824 BEGIN {
2825     %right = ('pow' => 22,
2826               'sassign=' => 7, 'aassign=' => 7,
2827               'multiply=' => 7, 'i_multiply=' => 7,
2828               'divide=' => 7, 'i_divide=' => 7,
2829               'modulo=' => 7, 'i_modulo=' => 7,
2830               'repeat=' => 7, 'refassign' => 7, 'refassign=' => 7,
2831               'add=' => 7, 'i_add=' => 7,
2832               'subtract=' => 7, 'i_subtract=' => 7,
2833               'concat=' => 7,
2834               'left_shift=' => 7, 'right_shift=' => 7,
2835               'bit_and=' => 7, 'sbit_and=' => 7, 'nbit_and=' => 7,
2836               'nbit_or=' => 7, 'nbit_xor=' => 7,
2837               'sbit_or=' => 7, 'sbit_xor=' => 7,
2838               'andassign' => 7,
2839               'orassign' => 7,
2840              );
2841 }
2842
2843 sub deparse_binop_right {
2844     my $self = shift;
2845     my($op, $right, $prec) = @_;
2846     if ($right{assoc_class($op)} && $right{assoc_class($right)}
2847         and $right{assoc_class($op)} == $right{assoc_class($right)})
2848     {
2849         return $self->deparse($right, $prec - .00001);
2850     } else {
2851         return $self->deparse($right, $prec);   
2852     }
2853 }
2854
2855 sub binop {
2856     my $self = shift;
2857     my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
2858     my $left = $op->first;
2859     my $right = $op->last;
2860     my $eq = "";
2861     if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
2862         $eq = "=";
2863         $prec = 7;
2864     }
2865     if ($flags & SWAP_CHILDREN) {
2866         ($left, $right) = ($right, $left);
2867     }
2868     my $leftop = $left;
2869     $left = $self->deparse_binop_left($op, $left, $prec);
2870     $left = "($left)" if $flags & LIST_CONTEXT
2871                      and    $left !~ /^(my|our|local|)[\@\(]/
2872                          || do {
2873                                 # Parenthesize if the left argument is a
2874                                 # lone repeat op.
2875                                 my $left = $leftop->first->sibling;
2876                                 $left->name eq 'repeat'
2877                                     && null($left->sibling);
2878                             };
2879     $right = $self->deparse_binop_right($op, $right, $prec);
2880     return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
2881 }
2882
2883 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2884 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2885 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18,  ASSIGN) }
2886 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2887 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2888 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2889 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2890 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
2891 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2892 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2893 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
2894
2895 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
2896 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
2897 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
2898 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
2899 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
2900 *pp_nbit_and = *pp_bit_and;
2901 *pp_nbit_or  = *pp_bit_or;
2902 *pp_nbit_xor = *pp_bit_xor;
2903 sub pp_sbit_and { maybe_targmy(@_, \&binop, "&.", 13, ASSIGN) }
2904 sub pp_sbit_or { maybe_targmy(@_, \&binop, "|.", 12, ASSIGN) }
2905 sub pp_sbit_xor { maybe_targmy(@_, \&binop, "^.", 12, ASSIGN) }
2906
2907 sub pp_eq { binop(@_, "==", 14) }
2908 sub pp_ne { binop(@_, "!=", 14) }
2909 sub pp_lt { binop(@_, "<", 15) }
2910 sub pp_gt { binop(@_, ">", 15) }
2911 sub pp_ge { binop(@_, ">=", 15) }
2912 sub pp_le { binop(@_, "<=", 15) }
2913 sub pp_ncmp { binop(@_, "<=>", 14) }
2914 sub pp_i_eq { binop(@_, "==", 14) }
2915 sub pp_i_ne { binop(@_, "!=", 14) }
2916 sub pp_i_lt { binop(@_, "<", 15) }
2917 sub pp_i_gt { binop(@_, ">", 15) }
2918 sub pp_i_ge { binop(@_, ">=", 15) }
2919 sub pp_i_le { binop(@_, "<=", 15) }
2920 sub pp_i_ncmp { maybe_targmy(@_, \&binop, "<=>", 14) }
2921
2922 sub pp_seq { binop(@_, "eq", 14) }
2923 sub pp_sne { binop(@_, "ne", 14) }
2924 sub pp_slt { binop(@_, "lt", 15) }
2925 sub pp_sgt { binop(@_, "gt", 15) }
2926 sub pp_sge { binop(@_, "ge", 15) }
2927 sub pp_sle { binop(@_, "le", 15) }
2928 sub pp_scmp { maybe_targmy(@_, \&binop, "cmp", 14) }
2929
2930 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
2931 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
2932
2933 sub pp_smartmatch {
2934     my ($self, $op, $cx) = @_;
2935     if ($op->flags & OPf_SPECIAL) {
2936         return $self->deparse($op->last, $cx);
2937     }
2938     else {
2939         binop(@_, "~~", 14);
2940     }
2941 }
2942
2943 # '.' is special because concats-of-concats are optimized to save copying
2944 # by making all but the first concat stacked. The effect is as if the
2945 # programmer had written '($a . $b) .= $c', except legal.
2946 sub pp_concat { maybe_targmy(@_, \&real_concat) }
2947 sub real_concat {
2948     my $self = shift;
2949     my($op, $cx) = @_;
2950     my $left = $op->first;
2951     my $right = $op->last;
2952     my $eq = "";
2953     my $prec = 18;
2954     if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
2955         $eq = "=";
2956         $prec = 7;
2957     }
2958     $left = $self->deparse_binop_left($op, $left, $prec);
2959     $right = $self->deparse_binop_right($op, $right, $prec);
2960     return $self->maybe_parens("$left .$eq $right", $cx, $prec);
2961 }
2962
2963 sub pp_repeat { maybe_targmy(@_, \&repeat) }
2964
2965 # 'x' is weird when the left arg is a list
2966 sub repeat {
2967     my $self = shift;
2968     my($op, $cx) = @_;
2969     my $left = $op->first;
2970     my $right = $op->last;
2971     my $eq = "";
2972     my $prec = 19;
2973     if ($op->flags & OPf_STACKED) {
2974         $eq = "=";
2975         $prec = 7;
2976     }
2977     if (null($right)) { # list repeat; count is inside left-side ex-list
2978                         # in 5.21.5 and earlier
2979         my $kid = $left->first->sibling; # skip pushmark
2980         my @exprs;
2981         for (; !null($kid->sibling); $kid = $kid->sibling) {
2982             push @exprs, $self->deparse($kid, 6);
2983         }
2984         $right = $kid;
2985         $left = "(" . join(", ", @exprs). ")";
2986     } else {
2987         my $dolist = $op->private & OPpREPEAT_DOLIST;
2988         $left = $self->deparse_binop_left($op, $left, $dolist ? 1 : $prec);
2989         if ($dolist) {
2990             $left = "($left)";
2991         }
2992     }
2993     $right = $self->deparse_binop_right($op, $right, $prec);
2994     return $self->maybe_parens("$left x$eq $right", $cx, $prec);
2995 }
2996
2997 sub range {
2998     my $self = shift;
2999     my ($op, $cx, $type) = @_;
3000     my $left = $op->first;
3001     my $right = $left->sibling;
3002     $left = $self->deparse($left, 9);
3003     $right = $self->deparse($right, 9);
3004     return $self->maybe_parens("$left $type $right", $cx, 9);
3005 }
3006
3007 sub pp_flop {
3008     my $self = shift;
3009     my($op, $cx) = @_;
3010     my $flip = $op->first;
3011     my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
3012     return $self->range($flip->first, $cx, $type);
3013 }
3014
3015 # one-line while/until is handled in pp_leave
3016
3017 sub logop {
3018     my $self = shift;
3019     my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
3020     my $left = $op->first;
3021     my $right = $op->first->sibling;
3022     $blockname &&= $self->keyword($blockname);
3023     if ($cx < 1 and is_scope($right) and $blockname
3024         and $self->{'expand'} < 7)
3025     { # if ($a) {$b}
3026         $left = $self->deparse($left, 1);
3027         $right = $self->deparse($right, 0);
3028         return "$blockname ($left) {\n\t$right\n\b}\cK";
3029     } elsif ($cx < 1 and $blockname and not $self->{'parens'}
3030              and $self->{'expand'} < 7) { # $b if $a
3031         $right = $self->deparse($right, 1);
3032         $left = $self->deparse($left, 1);
3033         return "$right $blockname $left";
3034     } elsif ($cx > $lowprec and $highop) { # $a && $b
3035         $left = $self->deparse_binop_left($op, $left, $highprec);
3036         $right = $self->deparse_binop_right($op, $right, $highprec);
3037         return $self->maybe_parens("$left $highop $right", $cx, $highprec);
3038     } else { # $a and $b
3039         $left = $self->deparse_binop_left($op, $left, $lowprec);
3040         $right = $self->deparse_binop_right($op, $right, $lowprec);
3041         return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
3042     }
3043 }
3044
3045 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
3046 sub pp_or  { logop(@_, "or",  2, "||", 10, "unless") }
3047 sub pp_dor { logop(@_, "//", 10) }
3048
3049 # xor is syntactically a logop, but it's really a binop (contrary to
3050 # old versions of opcode.pl). Syntax is what matters here.
3051 sub pp_xor { logop(@_, "xor", 2, "",   0,  "") }
3052
3053 sub logassignop {
3054     my $self = shift;
3055     my ($op, $cx, $opname) = @_;
3056     my $left = $op->first;
3057     my $right = $op->first->sibling->first; # skip sassign
3058     $left = $self->deparse($left, 7);
3059     $right = $self->deparse($right, 7);
3060     return $self->maybe_parens("$left $opname $right", $cx, 7);
3061 }
3062
3063 sub pp_andassign { logassignop(@_, "&&=") }
3064 sub pp_orassign  { logassignop(@_, "||=") }
3065 sub pp_dorassign { logassignop(@_, "//=") }
3066
3067 sub rv2gv_or_string {
3068     my($self,$op) = @_;
3069     if ($op->name eq "gv") { # could be open("open") or open("###")
3070         my($name,$quoted) =
3071             $self->stash_variable_name("", $self->gv_or_padgv($op));
3072         $quoted ? $name : "*$name";
3073     }
3074     else {
3075         $self->deparse($op, 6);
3076     }
3077 }
3078
3079 sub listop {
3080     my $self = shift;
3081     my($op, $cx, $name, $kid, $nollafr) = @_;
3082     my(@exprs);
3083     my $parens = ($cx >= 5) || $self->{'parens'};
3084     $kid ||= $op->first->sibling;
3085     # If there are no arguments, add final parentheses (or parenthesize the
3086     # whole thing if the llafr does not apply) to account for cases like
3087     # (return)+1 or setpgrp()+1.  When the llafr does not apply, we use a
3088     # precedence of 6 (< comma), as "return, 1" does not need parentheses.
3089     if (null $kid) {
3090         return $nollafr
3091                 ? $self->maybe_parens($self->keyword($name), $cx, 7)
3092                 : $self->keyword($name) . '()' x (7 < $cx);
3093     }
3094     my $first;
3095     my $fullname = $self->keyword($name);
3096     my $proto = prototype("CORE::$name");
3097     if (
3098          (     (defined $proto && $proto =~ /^;?\*/)
3099             || $name eq 'select' # select(F) doesn't have a proto
3100          )
3101          && $kid->name eq "rv2gv"
3102          && !($kid->private & OPpLVAL_INTRO)
3103     ) {
3104         $first = $self->rv2gv_or_string($kid->first);
3105     }
3106     else {
3107         $first = $self->deparse($kid, 6);
3108     }
3109     if ($name eq "chmod" && $first =~ /^\d+$/) {
3110         $first = sprintf("%#o", $first);
3111     }
3112     $first = "+$first"
3113         if not $parens and not $nollafr and substr($first, 0, 1) eq "(";
3114     push @exprs, $first;
3115     $kid = $kid->sibling;
3116     if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv"
3117          && !($kid->private & OPpLVAL_INTRO)) {
3118         push @exprs, $first = $self->rv2gv_or_string($kid->first);
3119         $kid = $kid->sibling;
3120     }
3121     for (; !null($kid); $kid = $kid->sibling) {
3122         push @exprs, $self->deparse($kid, 6);
3123     }
3124     if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) {
3125         return "$exprs[0] = $fullname"
3126                  . ($parens ? "($exprs[0])" : " $exprs[0]");
3127     }
3128
3129     if ($parens && $nollafr) {
3130         return "($fullname " . join(", ", @exprs) . ")";
3131     } elsif ($parens) {
3132         return "$fullname(" . join(", ", @exprs) . ")";
3133     } else {
3134         return "$fullname " . join(", ", @exprs);
3135     }
3136 }
3137
3138 sub pp_bless { listop(@_, "bless") }
3139 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
3140 sub pp_substr {
3141     my ($self,$op,$cx) = @_;
3142     if ($op->private & OPpSUBSTR_REPL_FIRST) {
3143         return
3144            listop($self, $op, 7, "substr", $op->first->sibling->sibling)
3145          . " = "
3146          . $self->deparse($op->first->sibling, 7);
3147     }
3148     maybe_local(@_, listop(@_, "substr"))
3149 }
3150 sub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) }
3151 sub pp_index { maybe_targmy(@_, \&listop, "index") }
3152 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
3153 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
3154 sub pp_formline { listop(@_, "formline") } # see also deparse_format
3155 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
3156 sub pp_unpack { listop(@_, "unpack") }
3157 sub pp_pack { listop(@_, "pack") }
3158 sub pp_join { maybe_targmy(@_, \&listop, "join") }
3159 sub pp_splice { listop(@_, "splice") }
3160 sub pp_push { maybe_targmy(@_, \&listop, "push") }
3161 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
3162 sub pp_reverse { listop(@_, "reverse") }
3163 sub pp_warn { listop(@_, "warn") }
3164 sub pp_die { listop(@_, "die") }
3165 sub pp_return { listop(@_, "return", undef, 1) } # llafr does not apply
3166 sub pp_open { listop(@_, "open") }
3167 sub pp_pipe_op { listop(@_, "pipe") }
3168 sub pp_tie { listop(@_, "tie") }
3169 sub pp_binmode { listop(@_, "binmode") }
3170 sub pp_dbmopen { listop(@_, "dbmopen") }
3171 sub pp_sselect { listop(@_, "select") }
3172 sub pp_select { listop(@_, "select") }
3173 sub pp_read { listop(@_, "read") }
3174 sub pp_sysopen { listop(@_, "sysopen") }
3175 sub pp_sysseek { listop(@_, "sysseek") }
3176 sub pp_sysread { listop(@_, "sysread") }
3177 sub pp_syswrite { listop(@_, "syswrite") }
3178 sub pp_send { listop(@_, "send") }
3179 sub pp_recv { listop(@_, "recv") }
3180 sub pp_seek { listop(@_, "seek") }
3181 sub pp_fcntl { listop(@_, "fcntl") }
3182 sub pp_ioctl { listop(@_, "ioctl") }
3183 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
3184 sub pp_socket { listop(@_, "socket") }
3185 sub pp_sockpair { listop(@_, "socketpair") }
3186 sub pp_bind { listop(@_, "bind") }
3187 sub pp_connect { listop(@_, "connect") }
3188 sub pp_listen { listop(@_, "listen") }
3189 sub pp_accept { listop(@_, "accept") }
3190 sub pp_shutdown { listop(@_, "shutdown") }
3191 sub pp_gsockopt { listop(@_, "getsockopt") }
3192 sub pp_ssockopt { listop(@_, "setsockopt") }
3193 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
3194 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
3195 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
3196 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
3197 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
3198 sub pp_link { maybe_targmy(@_, \&listop, "link") }
3199 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
3200 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
3201 sub pp_open_dir { listop(@_, "opendir") }
3202 sub pp_seekdir { listop(@_, "seekdir") }
3203 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
3204 sub pp_system { maybe_targmy(@_, \&indirop, "system") }
3205 sub pp_exec { maybe_targmy(@_, \&indirop, "exec") }
3206 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
3207 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
3208 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
3209 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
3210 sub pp_shmget { listop(@_, "shmget") }
3211 sub pp_shmctl { listop(@_, "shmctl") }
3212 sub pp_shmread { listop(@_, "shmread") }
3213 sub pp_shmwrite { listop(@_, "shmwrite") }
3214 sub pp_msgget { listop(@_, "msgget") }
3215 sub pp_msgctl { listop(@_, "msgctl") }
3216 sub pp_msgsnd { listop(@_, "msgsnd") }
3217 sub pp_msgrcv { listop(@_, "msgrcv") }
3218 sub pp_semget { listop(@_, "semget") }
3219 sub pp_semctl { listop(@_, "semctl") }
3220 sub pp_semop { listop(@_, "semop") }
3221 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
3222 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
3223 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
3224 sub pp_gsbyname { listop(@_, "getservbyname") }
3225 sub pp_gsbyport { listop(@_, "getservbyport") }
3226 sub pp_syscall { listop(@_, "syscall") }
3227
3228 sub pp_glob {
3229     my $self = shift;
3230     my($op, $cx) = @_;
3231     my $kid = $op->first->sibling;  # skip pushmark
3232     my $keyword =
3233         $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
3234     my $text = $self->deparse($kid);
3235     return $cx >= 5 || $self->{'parens'}
3236         ? "$keyword($text)"
3237         : "$keyword $text";
3238 }
3239
3240 # Truncate is special because OPf_SPECIAL makes a bareword first arg
3241 # be a filehandle. This could probably be better fixed in the core
3242 # by moving the GV lookup into ck_truc.
3243
3244 sub pp_truncate {
3245     my $self = shift;
3246     my($op, $cx) = @_;
3247     my(@exprs);
3248     my $parens = ($cx >= 5) || $self->{'parens'};
3249     my $kid = $op->first->sibling;
3250     my $fh;
3251     if ($op->flags & OPf_SPECIAL) {
3252         # $kid is an OP_CONST
3253         $fh = $self->const_sv($kid)->PV;
3254     } else {
3255         $fh = $self->deparse($kid, 6);
3256         $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
3257     }
3258     my $len = $self->deparse($kid->sibling, 6);
3259     my $name = $self->keyword('truncate');
3260     if ($parens) {
3261         return "$name($fh, $len)";
3262     } else {
3263         return "$name $fh, $len";
3264     }
3265 }
3266
3267 sub indirop {
3268     my $self = shift;
3269     my($op, $cx, $name) = @_;
3270     my($expr, @exprs);
3271     my $firstkid = my $kid = $op->first->sibling;
3272     my $indir = "";
3273     if ($op->flags & OPf_STACKED) {
3274         $indir = $kid;
3275         $indir = $indir->first; # skip rv2gv
3276         if (is_scope($indir)) {
3277             $indir = "{" . $self->deparse($indir, 0) . "}";
3278             $indir = "{;}" if $indir eq "{}";
3279         } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
3280             $indir = $self->const_sv($indir)->PV;
3281         } else {
3282             $indir = $self->deparse($indir, 24);
3283         }
3284         $indir = $indir . " ";
3285         $kid = $kid->sibling;
3286     }
3287     if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
3288         $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
3289                                                   : '{$a <=> $b} ';
3290     }
3291     elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
3292         $indir = '{$b cmp $a} ';
3293     }
3294     for (; !null($kid); $kid = $kid->sibling) {
3295         $expr = $self->deparse($kid, !$indir && $kid == $firstkid && $name eq "sort" && $firstkid->name eq "entersub" ? 16 : 6);
3296         push @exprs, $expr;
3297     }
3298     my $name2;
3299     if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
3300         $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort');
3301     }
3302     else { $name2 = $self->keyword($name) }
3303     if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
3304         return "$exprs[0] = $name2 $indir $exprs[0]";
3305     }
3306
3307     my $args = $indir . join(", ", @exprs);
3308     if ($indir ne "" && $name eq "sort") {
3309         # We don't want to say "sort(f 1, 2, 3)", since perl -w will
3310         # give bareword warnings in that case. Therefore if context
3311         # requires, we'll put parens around the outside "(sort f 1, 2,
3312         # 3)". Unfortunately, we'll currently think the parens are
3313         # necessary more often that they really are, because we don't
3314         # distinguish which side of an assignment we're on.
3315         if ($cx >= 5) {
3316             return "($name2 $args)";
3317         } else {
3318             return "$name2 $args";
3319         }
3320     } elsif (
3321         !$indir && $name eq "sort"
3322       && !null($op->first->sibling)
3323       && $op->first->sibling->name eq 'entersub'
3324     ) {
3325         # We cannot say sort foo(bar), as foo will be interpreted as a
3326         # comparison routine.  We have to say sort(...) in that case.
3327         return "$name2($args)";
3328     } else {
3329         return length $args
3330                 ? $self->maybe_parens_func($name2, $args, $cx, 5)
3331                 : $name2 . '()' x (7 < $cx);
3332     }
3333
3334 }
3335
3336 sub pp_prtf { indirop(@_, "printf") }
3337 sub pp_print { indirop(@_, "print") }
3338 sub pp_say  { indirop(@_, "say") }
3339 sub pp_sort { indirop(@_, "sort") }
3340
3341 sub mapop {
3342     my $self = shift;
3343     my($op, $cx, $name) = @_;
3344     my($expr, @exprs);
3345     my $kid = $op->first; # this is the (map|grep)start
3346     $kid = $kid->first->sibling; # skip a pushmark
3347     my $code = $kid->first; # skip a null
3348     if (is_scope $code) {
3349         $code = "{" . $self->deparse($code, 0) . "} ";
3350     } else {
3351         $code = $self->deparse($code, 24);
3352         $code .= ", " if !null($kid->sibling);
3353     }
3354     $kid = $kid->sibling;
3355     for (; !null($kid); $kid = $kid->sibling) {
3356         $expr = $self->deparse($kid, 6);
3357         push @exprs, $expr if defined $expr;
3358     }
3359     return $self->maybe_parens_func($self->keyword($name),
3360                                     $code . join(", ", @exprs), $cx, 5);
3361 }
3362
3363 sub pp_mapwhile { mapop(@_, "map") }
3364 sub pp_grepwhile { mapop(@_, "grep") }
3365 sub pp_mapstart { baseop(@_, "map") }
3366 sub pp_grepstart { baseop(@_, "grep") }
3367
3368 my %uses_intro;
3369 BEGIN {
3370     @uses_intro{
3371         eval { require B::Op_private }
3372           ? @{$B::Op_private::ops_using{OPpLVAL_INTRO}}
3373           : qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice
3374                hslice delete padsv padav padhv enteriter entersub padrange
3375                pushmark cond_expr refassign list)
3376     } = ();
3377     delete @uses_intro{qw( lvref lvrefslice lvavref entersub )};
3378 }
3379
3380 sub pp_list {
3381     my $self = shift;
3382     my($op, $cx) = @_;
3383     my($expr, @exprs);
3384     my $kid = $op->first->sibling; # skip pushmark
3385     return '' if class($kid) eq 'NULL';
3386     my $lop;
3387     my $local = "either"; # could be local(...), my(...), state(...) or our(...)
3388     my $type;
3389     for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
3390         my $lopname = $lop->name;
3391         my $loppriv = $lop->private;
3392         my $newtype;
3393         if ($lopname =~ /^pad[ash]v$/ && $loppriv & OPpLVAL_INTRO) {
3394             if ($loppriv & OPpPAD_STATE) { # state()
3395                 ($local = "", last) if $local !~ /^(?:either|state)$/;
3396                 $local = "state";
3397             } else { # my()
3398                 ($local = "", last) if $local !~ /^(?:either|my)$/;
3399                 $local = "my";
3400             }
3401             my $padname = $self->padname_sv($lop->targ);
3402             if ($padname->FLAGS & SVpad_TYPED) {
3403                 $newtype = $padname->SvSTASH->NAME;
3404             }
3405         } elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/
3406                         && $loppriv & OPpOUR_INTRO
3407                 or $lopname eq "null" && class($lop) eq 'UNOP'
3408                         && $lop->first->name eq "gvsv"
3409                         && $lop->first->private & OPpOUR_INTRO) { # our()
3410             my $newlocal = "local " x !!($loppriv & OPpLVAL_INTRO) . "our";
3411             ($local = "", last)
3412                 if $local ne 'either' && $local ne $newlocal;
3413             $local = $newlocal;
3414             my $funny = !$1 || $1 eq 's' ? '$' : $1 eq 'a' ? '@' : '%';
3415             if (my $t = $self->find_our_type(
3416                     $funny . $self->gv_or_padgv($lop->first)->NAME
3417                )) {
3418                 $newtype = $t;
3419             }
3420         } elsif ($lopname ne 'undef'
3421            and    !($loppriv & OPpLVAL_INTRO)
3422                || !exists $uses_intro{$lopname eq 'null'
3423                                         ? substr B::ppname($lop->targ), 3
3424                                         : $lopname})
3425         {
3426             $local = ""; # or not
3427             last;
3428         } elsif ($lopname ne "undef")
3429         {
3430             # local()
3431             ($local = "", last) if $local !~ /^(?:either|local)$/;
3432             $local = "local";
3433         }
3434         if (defined $type && defined $newtype && $newtype ne $type) {
3435             $local = '';
3436             last;
3437         }
3438         $type = $newtype;
3439     }
3440     $local = "" if $local eq "either"; # no point if it's all undefs
3441     $local &&= join ' ', map $self->keyword($_), split / /, $local;
3442     $local .= " $type " if $local && length $type;
3443     return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
3444     for (; !null($kid); $kid = $kid->sibling) {
3445         if ($local) {
3446             if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
3447                 $lop = $kid->first;
3448             } else {
3449                 $lop = $kid;
3450             }
3451             $self->{'avoid_local'}{$$lop}++;
3452             $expr = $self->deparse($kid, 6);
3453             delete $self->{'avoid_local'}{$$lop};
3454         } else {
3455             $expr = $self->deparse($kid, 6);
3456         }
3457         push @exprs, $expr;
3458     }
3459     if ($local) {
3460         return "$local(" . join(", ", @exprs) . ")";
3461     } else {
3462         return $self->maybe_parens( join(", ", @exprs), $cx, 6);        
3463     }
3464 }
3465
3466 sub is_ifelse_cont {
3467     my $op = shift;
3468     return ($op->name eq "null" and class($op) eq "UNOP"
3469             and $op->first->name =~ /^(and|cond_expr)$/
3470             and is_scope($op->first->first->sibling));
3471 }
3472
3473 sub pp_cond_expr {
3474     my $self = shift;
3475     my($op, $cx) = @_;
3476     my $cond = $op->first;
3477     my $true = $cond->sibling;
3478     my $false = $true->sibling;
3479     my $cuddle = $self->{'cuddle'};
3480     unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
3481             (is_scope($false) || is_ifelse_cont($false))
3482             and $self->{'expand'} < 7) {
3483         $cond = $self->deparse($cond, 8);
3484         $true = $self->deparse($true, 6);
3485         $false = $self->deparse($false, 8);
3486         return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
3487     }
3488
3489     $cond = $self->deparse($cond, 1);
3490     $true = $self->deparse($true, 0);
3491     my $head = $self->keyword("if") . " ($cond) {\n\t$true\n\b}";
3492     my @elsifs;
3493     my $elsif;
3494     while (!null($false) and is_ifelse_cont($false)) {
3495         my $newop = $false->first;
3496         my $newcond = $newop->first;
3497         my $newtrue = $newcond->sibling;
3498         $false = $newtrue->sibling; # last in chain is OP_AND => no else
3499         if ($newcond->name eq "lineseq")
3500         {
3501             # lineseq to ensure correct line numbers in elsif()
3502             # Bug #37302 fixed by change #33710.
3503             $newcond = $newcond->first->sibling;
3504         }
3505         $newcond = $self->deparse($newcond, 1);
3506         $newtrue = $self->deparse($newtrue, 0);
3507         $elsif ||= $self->keyword("elsif");
3508         push @elsifs, "$elsif ($newcond) {\n\t$newtrue\n\b}";
3509     }
3510     if (!null($false)) {
3511         $false = $cuddle . $self->keyword("else") . " {\n\t" .
3512           $self->deparse($false, 0) . "\n\b}\cK";
3513     } else {
3514         $false = "\cK";
3515     }
3516     return $head . join($cuddle, "", @elsifs) . $false;
3517 }
3518
3519 sub pp_once {
3520     my ($self, $op, $cx) = @_;
3521     my $cond = $op->first;
3522     my $true = $cond->sibling;
3523
3524     my $ret = $self->deparse($true, $cx);
3525     $ret =~ s/^(\(?)\$/$1 . $self->keyword("state") . ' $'/e;
3526     $ret;
3527 }
3528
3529 sub loop_common {
3530     my $self = shift;
3531     my($op, $cx, $init) = @_;
3532     my $enter = $op->first;
3533     my $kid = $enter->sibling;
3534     local(@$self{qw'curstash warnings hints hinthash'})
3535                 = @$self{qw'curstash warnings hints hinthash'};
3536     my $head = "";
3537     my $bare = 0;
3538     my $body;
3539     my $cond = undef;
3540     my $name;
3541     if ($kid->name eq "lineseq") { # bare or infinite loop
3542         if ($kid->last->name eq "unstack") { # infinite
3543             $head = "while (1) "; # Can't use for(;;) if there's a continue
3544             $cond = "";
3545         } else {
3546             $bare = 1;
3547         }
3548         $body = $kid;
3549     } elsif ($enter->name eq "enteriter") { # foreach
3550         my $ary = $enter->first->sibling; # first was pushmark
3551         my $var = $ary->sibling;
3552         if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
3553             # "reverse" was optimised away
3554             $ary = listop($self, $ary->first->sibling, 1, 'reverse');
3555         } elsif ($enter->flags & OPf_STACKED
3556             and not null $ary->first->sibling->sibling)
3557         {
3558             $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
3559               $self->deparse($ary->first->sibling->sibling, 9);
3560         } else {
3561             $ary = $self->deparse($ary, 1);
3562         }
3563         if (null $var) {
3564             $var = $self->pp_padsv($enter, 1, 1);
3565         } elsif ($var->name eq "rv2gv") {
3566             $var = $self->pp_rv2sv($var, 1);
3567             if ($enter->private & OPpOUR_INTRO) {
3568                 # our declarations don't have package names
3569                 $var =~ s/^(.).*::/$1/;
3570                 $var = "our $var";
3571             }
3572         } elsif ($var->name eq "gv") {
3573             $var = "\$" . $self->deparse($var, 1);
3574         } else {
3575             $var = $self->deparse($var, 1);
3576         }
3577         $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
3578         if (!is_state $body->first and $body->first->name !~ /^(?:stub|leave|scope)$/) {
3579             confess unless $var eq '$_';
3580             $body = $body->first;
3581             return $self->deparse($body, 2) . " "
3582                  . $self->keyword("foreach") . " ($ary)";
3583         }
3584         $head = "foreach $var ($ary) ";
3585     } elsif ($kid->name eq "null") { # while/until
3586         $kid = $kid->first;
3587         $name = {"and" => "while", "or" => "until"}->{$kid->name};
3588         $cond = $kid->first;
3589         $body = $kid->first->sibling;
3590     } elsif ($kid->name eq "stub") { # bare and empty
3591         return "{;}"; # {} could be a hashref
3592     }
3593     # If there isn't a continue block, then the next pointer for the loop
3594     # will point to the unstack, which is kid's last child, except
3595     # in a bare loop, when it will point to the leaveloop. When neither of
3596     # these conditions hold, then the second-to-last child is the continue
3597     # block (or the last in a bare loop).
3598     my $cont_start = $enter->nextop;
3599     my $cont;
3600     my $precond;
3601     my $postcond;
3602     if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
3603         if ($bare) {
3604             $cont = $body->last;
3605         } else {
3606             $cont = $body->first;
3607             while (!null($cont->sibling->sibling)) {
3608                 $cont = $cont->sibling;
3609             }
3610         }
3611         my $state = $body->first;
3612         my $cuddle = $self->{'cuddle'};
3613         my @states;
3614         for (; $$state != $$cont; $state = $state->sibling) {
3615             push @states, $state;
3616         }
3617         $body = $self->lineseq(undef, 0, @states);
3618         if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
3619             $precond = "for ($init; ";
3620             $postcond = "; " . $self->deparse($cont, 1) .") ";
3621             $cont = "\cK";
3622         } else {
3623             $cont = $cuddle . "continue {\n\t" .
3624               $self->deparse($cont, 0) . "\n\b}\cK";
3625         }
3626     } else {
3627         return "" if !defined $body;
3628         if (length $init) {
3629             $precond = "for ($init; ";
3630             $postcond = ";) ";
3631         }
3632         $cont = "\cK";
3633         $body = $self->deparse($body, 0);
3634     }
3635     if ($precond) { # for(;;)
3636         $cond &&= $name eq 'until'
3637                     ? listop($self, undef, 1, "not", $cond->first)
3638                     : $self->deparse($cond, 1);
3639         $head = "$precond$cond$postcond";
3640     }
3641     if ($name && !$head) {
3642         ref $cond and $cond = $self->deparse($cond, 1);
3643         $head = "$name ($cond) ";
3644     }
3645     $head =~ s/^(for(?:each)?|while|until)/$self->keyword($1)/e;
3646     $body =~ s/;?$/;\n/;
3647
3648     return $head . "{\n\t" . $body . "\b}" . $cont;
3649 }
3650
3651 sub pp_leaveloop { shift->loop_common(@_, "") }
3652
3653 sub for_loop {
3654     my $self = shift;
3655     my($op, $cx) = @_;
3656     my $init = $self->deparse($op, 1);
3657     my $s = $op->sibling;
3658     my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling;
3659     return $self->loop_common($ll, $cx, $init);
3660 }
3661
3662 sub pp_leavetry {
3663     my $self = shift;
3664     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
3665 }
3666
3667 sub _op_is_or_was {
3668   my ($op, $expect_type) = @_;
3669   my $type = $op->type;
3670   return($type == $expect_type
3671          || ($type == OP_NULL && $op->targ == $expect_type));
3672 }
3673
3674 sub pp_null {
3675     my($self, $op, $cx) = @_;
3676     if (class($op) eq "OP") {
3677         # old value is lost
3678         return $self->{'ex_const'} if $op->targ == OP_CONST;
3679     } elsif (class ($op) eq "COP") {
3680             return &pp_nextstate;
3681     } elsif ($op->first->name eq 'pushmark'
3682              or $op->first->name eq 'null'
3683                 && $op->first->targ == OP_PUSHMARK
3684                 && _op_is_or_was($op, OP_LIST)) {
3685         return $self->pp_list($op, $cx);
3686     } elsif ($op->first->name eq "enter") {
3687         return $self->pp_leave($op, $cx);
3688     } elsif ($op->first->name eq "leave") {
3689         return $self->pp_leave($op->first, $cx);
3690     } elsif ($op->first->name eq "scope") {
3691         return $self->pp_scope($op->first, $cx);
3692     } elsif ($op->targ == OP_STRINGIFY) {
3693         return $self->dquote($op, $cx);
3694     } elsif ($op->targ == OP_GLOB) {
3695         return $self->pp_glob(
3696                  $op->first    # entersub
3697                     ->first    # ex-list
3698                     ->first    # pushmark
3699                     ->sibling, # glob
3700                  $cx
3701                );
3702     } elsif (!null($op->first->sibling) and
3703              $op->first->sibling->name eq "readline" and
3704              $op->first->sibling->flags & OPf_STACKED) {
3705         return $self->maybe_parens($self->deparse($op->first, 7) . " = "
3706                                    . $self->deparse($op->first->sibling, 7),
3707                                    $cx, 7);
3708     } elsif (!null($op->first->sibling) and
3709              $op->first->sibling->name =~ /^transr?\z/ and
3710              $op->first->sibling->flags & OPf_STACKED) {
3711         return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
3712                                    . $self->deparse($op->first->sibling, 20),
3713                                    $cx, 20);
3714     } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
3715         return ($self->lex_in_scope("&do") ? "CORE::do" : "do")
3716              . " {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
3717     } elsif (!null($op->first->sibling) and
3718              $op->first->sibling->name eq "null" and
3719              class($op->first->sibling) eq "UNOP" and
3720              $op->first->sibling->first->flags & OPf_STACKED and
3721              $op->first->sibling->first->name eq "rcatline") {
3722         return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
3723                                    . $self->deparse($op->first->sibling, 18),
3724                                    $cx, 18);
3725     } else {
3726         return $self->deparse($op->first, $cx);
3727     }
3728 }
3729
3730 sub padname {
3731     my $self = shift;
3732     my $targ = shift;
3733     return $self->padname_sv($targ)->PVX;
3734 }
3735
3736 sub padany {
3737     my $self = shift;
3738     my $op = shift;
3739     return substr($self->padname($op->targ), 1); # skip $/@/%
3740 }
3741
3742 sub pp_padsv {
3743     my $self = shift;
3744     my($op, $cx, $forbid_parens) = @_;
3745     my $targ = $op->targ;
3746     return $self->maybe_my($op, $cx, $self->padname($targ),
3747                            $self->padname_sv($targ),
3748                            $forbid_parens);
3749 }
3750
3751 sub pp_padav { pp_padsv(@_) }
3752 sub pp_padhv { pp_padsv(@_) }
3753
3754 sub gv_or_padgv {
3755     my $self = shift;
3756     my $op = shift;
3757     if (class($op) eq "PADOP") {
3758         return $self->padval($op->padix);
3759     } else { # class($op) eq "SVOP"
3760         return $op->gv;
3761     }
3762 }
3763
3764 sub pp_gvsv {
3765     my $self = shift;
3766     my($op, $cx) = @_;
3767     my $gv = $self->gv_or_padgv($op);
3768     return $self->maybe_local($op, $cx, $self->stash_variable("\$",
3769                                  $self->gv_name($gv), $cx));
3770 }
3771
3772 sub pp_gv {
3773     my $self = shift;
3774     my($op, $cx) = @_;
3775     my $gv = $self->gv_or_padgv($op);
3776     return $self->gv_name($gv);
3777 }
3778
3779 sub pp_aelemfast_lex {
3780     my $self = shift;
3781     my($op, $cx) = @_;
3782     my $name = $self->padname($op->targ);
3783     $name =~ s/^@/\$/;
3784     my $i = $op->private;
3785     $i -= 256 if $i > 127;
3786     return $name . "[" .  ($i + $self->{'arybase'}) . "]";
3787 }
3788
3789 sub pp_aelemfast {
3790     my $self = shift;
3791     my($op, $cx) = @_;
3792     # optimised PADAV, pre 5.15
3793     return $self->pp_aelemfast_lex(@_) if ($op->flags & OPf_SPECIAL);
3794
3795     my $gv = $self->gv_or_padgv($op);
3796     my($name,$quoted) = $self->stash_variable_name('@',$gv);
3797     $name = $quoted ? "$name->" : '$' . $name;
3798     my $i = $op->private;
3799     $i -= 256 if $i > 127;
3800     return $name . "[" .  ($i + $self->{'arybase'}) . "]";
3801 }
3802
3803 sub rv2x {
3804     my $self = shift;
3805     my($op, $cx, $type) = @_;
3806
3807     if (class($op) eq 'NULL' || !$op->can("first")) {
3808         carp("Unexpected op in pp_rv2x");
3809         return 'XXX';
3810     }
3811     my $kid = $op->first;
3812     if ($kid->name eq "gv") {
3813         return $self->stash_variable($type, $self->deparse($kid, 0), $cx);
3814     } elsif (is_scalar $kid) {
3815         my $str = $self->deparse($kid, 0);
3816         if ($str =~ /^\$([^\w\d])\z/) {
3817             # "$$+" isn't a legal way to write the scalar dereference
3818             # of $+, since the lexer can't tell you aren't trying to
3819             # do something like "$$ + 1" to get one more than your
3820             # PID. Either "${$+}" or "$${+}" are workable
3821             # disambiguations, but if the programmer did the former,
3822             # they'd be in the "else" clause below rather than here.
3823             # It's not clear if this should somehow be unified with
3824             # the code in dq and re_dq that also adds lexer
3825             # disambiguation braces.
3826             $str = '$' . "{$1}"; #'
3827         }
3828         return $type . $str;
3829     } else {
3830         return $type . "{" . $self->deparse($kid, 0) . "}";
3831     }
3832 }
3833
3834 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
3835 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
3836 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
3837
3838 # skip rv2av
3839 sub pp_av2arylen {
3840     my $self = shift;
3841     my($op, $cx) = @_;
3842     if ($op->first->name eq "padav") {
3843         return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
3844     } else {
3845         return $self->maybe_local($op, $cx,
3846                                   $self->rv2x($op->first, $cx, '$#'));
3847     }
3848 }
3849
3850 # skip down to the old, ex-rv2cv
3851 sub pp_rv2cv {
3852     my ($self, $op, $cx) = @_;
3853     if (!null($op->first) && $op->first->name eq 'null' &&
3854         $op->first->targ == OP_LIST)
3855     {
3856         return $self->rv2x($op->first->first->sibling, $cx, "&")
3857     }
3858     else {
3859         return $self->rv2x($op, $cx, "")
3860     }
3861 }
3862
3863 sub list_const {
3864     my $self = shift;
3865     my($cx, @list) = @_;
3866     my @a = map $self->const($_, 6), @list;
3867     if (@a == 0) {
3868         return "()";
3869     } elsif (@a == 1) {
3870         return $a[0];
3871     } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
3872         # collapse (-1,0,1,2) into (-1..2)
3873         my ($s, $e) = @a[0,-1];
3874         my $i = $s;
3875         return $self->maybe_parens("$s..$e", $cx, 9)
3876           unless grep $i++ != $_, @a;
3877     }
3878     return $self->maybe_parens(join(", ", @a), $cx, 6);
3879 }
3880
3881 sub pp_rv2av {
3882     my $self = shift;
3883     my($op, $cx) = @_;
3884     my $kid = $op->first;
3885     if ($kid->name eq "const") { # constant list
3886         my $av = $self->const_sv($kid);
3887         return $self->list_const($cx, $av->ARRAY);
3888     } else {
3889         return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
3890     }
3891  }
3892
3893 sub is_subscriptable {
3894     my $op = shift;
3895     if ($op->name =~ /^([ahg]elem|multideref$)/) {
3896         return 1;
3897     } elsif ($op->name eq "entersub") {
3898         my $kid = $op->first;
3899         return 0 unless null $kid->sibling;
3900         $kid = $kid->first;
3901         $kid = $kid->sibling until null $kid->sibling;
3902         return 0 if is_scope($kid);
3903         $kid = $kid->first;
3904         return 0 if $kid->name eq "gv" || $kid->name eq "padcv";
3905         return 0 if is_scalar($kid);
3906         return is_subscriptable($kid);  
3907     } else {
3908         return 0;
3909     }
3910 }
3911
3912 sub elem_or_slice_array_name
3913 {
3914     my $self = shift;
3915     my ($array, $left, $padname, $allow_arrow) = @_;
3916
3917     if ($array->name eq $padname) {
3918         return $self->padany($array);
3919     } elsif (is_scope($array)) { # ${expr}[0]
3920         return "{" . $self->deparse($array, 0) . "}";
3921     } elsif ($array->name eq "gv") {
3922         ($array, my $quoted) =
3923             $self->stash_variable_name(
3924                 $left eq '[' ? '@' : '%', $self->gv_or_padgv($array)
3925             );
3926         if (!$allow_arrow && $quoted) {
3927             # This cannot happen.
3928             die "Invalid variable name $array for slice";
3929         }
3930         return $quoted ? "$array->" : $array;
3931     } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
3932         return $self->deparse($array, 24);
3933     } else {
3934         return undef;
3935     }
3936 }
3937
3938 sub elem_or_slice_single_index
3939 {
3940     my $self = shift;
3941     my ($idx) = @_;
3942
3943     $idx = $self->deparse($idx, 1);
3944
3945     # Outer parens in an array index will confuse perl
3946     # if we're interpolating in a regular expression, i.e.
3947     # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
3948     #
3949     # If $self->{parens}, then an initial '(' will
3950     # definitely be paired with a final ')'. If
3951     # !$self->{parens}, the misleading parens won't
3952     # have been added in the first place.
3953     #
3954     # [You might think that we could get "(...)...(...)"
3955     # where the initial and final parens do not match
3956     # each other. But we can't, because the above would
3957     # only happen if there's an infix binop between the
3958     # two pairs of parens, and *that* means that the whole
3959     # expression would be parenthesized as well.]
3960     #
3961     $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
3962
3963     # Hash-element braces will autoquote a bareword inside themselves.
3964     # We need to make sure that C<$hash{warn()}> doesn't come out as
3965     # C<$hash{warn}>, which has a quite different meaning. Currently
3966     # B::Deparse will always quote strings, even if the string was a
3967     # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
3968     # for constant strings.) So we can cheat slightly here - if we see
3969     # a bareword, we know that it is supposed to be a function call.
3970     #
3971     $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
3972
3973     return $idx;
3974 }
3975
3976 sub elem {
3977     my $self = shift;
3978     my ($op, $cx, $left, $right, $padname) = @_;
3979     my($array, $idx) = ($op->first, $op->first->sibling);
3980
3981     $idx = $self->elem_or_slice_single_index($idx);
3982
3983     unless ($array->name eq $padname) { # Maybe this has been fixed     
3984         $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
3985     }
3986     if (my $array_name=$self->elem_or_slice_array_name
3987             ($array, $left, $padname, 1)) {
3988         return ($array_name =~ /->\z/
3989                     ? $array_name
3990                     : $array_name eq '#' ? '${#}' : "\$" . $array_name)
3991               . $left . $idx . $right;
3992     } else {
3993         # $x[20][3]{hi} or expr->[20]
3994         my $arrow = is_subscriptable($array) ? "" : "->";
3995         return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
3996     }
3997
3998 }
3999
4000 # a simplified version of elem_or_slice_array_name()
4001 # for the use of pp_multideref
4002
4003 sub multideref_var_name {
4004     my $self = shift;
4005     my ($gv, $is_hash) = @_;
4006
4007     my ($name, $quoted) =
4008         $self->stash_variable_name( $is_hash  ? '%' : '@', $gv);
4009     return $quoted ? "$name->"
4010                    : $name eq '#'
4011                         ? '${#}'       # avoid ${#}[1] => $#[1]
4012                         : '$' . $name;
4013 }
4014
4015
4016 sub pp_multideref {
4017     my $self = shift;
4018     my($op, $cx) = @_;
4019     my $text = "";
4020
4021     if ($op->private & OPpMULTIDEREF_EXISTS) {
4022         $text = $self->keyword("exists"). " ";
4023     }
4024     elsif ($op->private & OPpMULTIDEREF_DELETE) {
4025         $text = $self->keyword("delete"). " ";
4026     }
4027     elsif ($op->private & OPpLVAL_INTRO) {
4028         $text = $self->keyword("local"). " ";
4029     }
4030
4031     if ($op->first && ($op->first->flags & OPf_KIDS)) {
4032         # arbitrary initial expression, e.g. f(1,2,3)->[...]
4033         my $expr = $self->deparse($op->first, 24);
4034         # stop "exists (expr)->{...}" being interpreted as
4035         #"(exists (expr))->{...}"
4036         $expr = "+$expr" if $expr =~ /^\(/;
4037         $text .=  $expr;
4038     }
4039
4040     my @items = $op->aux_list($self->{curcv});
4041     my $actions = shift @items;
4042
4043     my $is_hash;
4044     my $derefs = 0;
4045
4046     while (1) {
4047         if (($actions & MDEREF_ACTION_MASK) == MDEREF_reload) {
4048             $actions = shift @items;
4049             next;
4050         }
4051
4052         $is_hash = (
4053            ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_pop_rv2hv_helem
4054         || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvsv_vivify_rv2hv_helem
4055         || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padsv_vivify_rv2hv_helem
4056         || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_vivify_rv2hv_helem
4057         || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem
4058         || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem
4059         );
4060
4061         if (   ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_padav_aelem
4062             || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem)
4063         {
4064             $derefs = 1;
4065             $text .= '$' . substr($self->padname(shift @items), 1);
4066         }
4067         elsif (   ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_gvav_aelem
4068                || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem)
4069         {
4070             $derefs = 1;
4071             $text .= $self->multideref_var_name(shift @items, $is_hash);
4072         }
4073         else {
4074             if (   ($actions & MDEREF_ACTION_MASK) ==
4075                                         MDEREF_AV_padsv_vivify_rv2av_aelem
4076                 || ($actions & MDEREF_ACTION_MASK) ==
4077                                         MDEREF_HV_padsv_vivify_rv2hv_helem)
4078             {
4079                 $text .= $self->padname(shift @items);
4080             }
4081             elsif (   ($actions & MDEREF_ACTION_MASK) ==
4082                                            MDEREF_AV_gvsv_vivify_rv2av_aelem
4083                    || ($actions & MDEREF_ACTION_MASK) ==
4084                                            MDEREF_HV_gvsv_vivify_rv2hv_helem)
4085             {
4086                 $text .= $self->multideref_var_name(shift @items, $is_hash);
4087             }
4088             elsif (   ($actions & MDEREF_ACTION_MASK) ==
4089                                            MDEREF_AV_pop_rv2av_aelem
4090                    || ($actions & MDEREF_ACTION_MASK) ==
4091                                            MDEREF_HV_pop_rv2hv_helem)
4092             {
4093                 if (   ($op->flags & OPf_KIDS)
4094                     && (   _op_is_or_was($op->first, OP_RV2AV)
4095                         || _op_is_or_was($op->first, OP_RV2HV))
4096                     && ($op->first->flags & OPf_KIDS)
4097                     && (   _op_is_or_was($op->first->first, OP_AELEM)
4098                         || _op_is_or_was($op->first->first, OP_HELEM))
4099                     )
4100                 {
4101                     $derefs++;
4102                 }
4103             }
4104
4105             $text .= '->' if !$derefs++;
4106         }
4107
4108
4109         if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_none) {
4110             last;
4111         }
4112
4113         $text .= $is_hash ? '{' : '[';
4114
4115         if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_const) {
4116             my $key = shift @items;
4117             if ($is_hash) {
4118                 $text .= $self->const($key, $cx);
4119             }
4120             else {
4121                 $text .= $key;
4122             }
4123         }
4124         elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_padsv) {
4125             $text .= $self->padname(shift @items);
4126         }
4127         elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_gvsv) {
4128             $text .= '$' .  ($self->stash_variable_name('$', shift @items))[0];
4129         }
4130
4131         $text .= $is_hash ? '}' : ']';
4132
4133         if ($actions & MDEREF_FLAG_last) {
4134             last;
4135         }
4136         $actions >>= MDEREF_SHIFT;
4137     }
4138
4139     return $text;
4140 }
4141
4142
4143 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
4144 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
4145
4146 sub pp_gelem {
4147     my $self = shift;
4148     my($op, $cx) = @_;
4149     my($glob, $part) = ($op->first, $op->last);
4150     $glob = $glob->first; # skip rv2gv
4151     $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
4152     my $scope = is_scope($glob);
4153     $glob = $self->deparse($glob, 0);
4154     $part = $self->deparse($part, 1);
4155     return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
4156 }
4157
4158 sub slice {
4159     my $self = shift;
4160     my ($op, $cx, $left, $right, $regname, $padname) = @_;
4161     my $last;
4162     my(@elems, $kid, $array, $list);
4163     if (class($op) eq "LISTOP") {
4164         $last = $op->last;
4165     } else { # ex-hslice inside delete()
4166         for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
4167         $last = $kid;
4168     }
4169     $array = $last;
4170     $array = $array->first
4171         if $array->name eq $regname or $array->name eq "null";
4172     $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
4173     $kid = $op->first->sibling; # skip pushmark
4174     if ($kid->name eq "list") {
4175         $kid = $kid->first->sibling; # skip list, pushmark
4176         for (; !null $kid; $kid = $kid->sibling) {
4177             push @elems, $self->deparse($kid, 6);
4178         }
4179         $list = join(", ", @elems);
4180     } else {
4181         $list = $self->elem_or_slice_single_index($kid);
4182     }
4183     my $lead = '@';
4184     $lead = '%' if $op->name =~ /^kv/i;
4185     return $lead . $array . $left . $list . $right;
4186 }
4187
4188 sub pp_aslice   { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
4189 sub pp_kvaslice {                 slice(@_, "[", "]", "rv2av", "padav")  }
4190 sub pp_hslice   { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
4191 sub pp_kvhslice {                 slice(@_, "{", "}", "rv2hv", "padhv")  }
4192
4193 sub pp_lslice {
4194     my $self = shift;
4195     my($op, $cx) = @_;
4196     my $idx = $op->first;
4197     my $list = $op->last;
4198     my(@elems, $kid);
4199     $list = $self->deparse($list, 1);
4200     $idx = $self->deparse($idx, 1);
4201     return "($list)" . "[$idx]";
4202 }
4203
4204 sub want_scalar {
4205     my $op = shift;
4206     return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
4207 }
4208
4209 sub want_list {
4210     my $op = shift;
4211     return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
4212 }
4213
4214 sub _method {
4215     my $self = shift;
4216     my($op, $cx) = @_;
4217     my $kid = $op->first->sibling; # skip pushmark
4218     my($meth, $obj, @exprs);
4219     if ($kid->name eq "list" and want_list $kid) {
4220         # When an indirect object isn't a bareword but the args are in
4221         # parens, the parens aren't part of the method syntax (the LLAFR
4222         # doesn't apply), but they make a list with OPf_PARENS set that
4223         # doesn't get flattened by the append_elem that adds the method,
4224         # making a (object, arg1, arg2, ...) list where the object
4225         # usually is. This can be distinguished from
4226         # '($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
4227         # object) because in the later the list is in scalar context
4228         # as the left side of -> always is, while in the former
4229         # the list is in list context as method arguments always are.
4230         # (Good thing there aren't method prototypes!)
4231         $meth = $kid->sibling;
4232         $kid = $kid->first->sibling; # skip pushmark
4233         $obj = $kid;
4234         $kid = $kid->sibling;
4235         for (; not null $kid; $kid = $kid->sibling) {
4236             push @exprs, $kid;
4237         }
4238     } else {
4239         $obj = $kid;
4240         $kid = $kid->sibling;
4241         for (; !null ($kid->sibling) && $kid->name!~/^method(?:_named)?\z/;
4242               $kid = $kid->sibling) {
4243             push @exprs, $kid
4244         }
4245         $meth = $kid;
4246     }
4247
4248     if ($meth->name eq "method_named") {
4249         $meth = $self->meth_sv($meth)->PV;
4250     } elsif ($meth->name eq "method_super") {
4251         $meth = "SUPER::".$self->meth_sv($meth)->PV;
4252     } elsif ($meth->name eq "method_redir") {
4253         $meth = $self->meth_rclass_sv($meth)->PV.'::'.$self->meth_sv($meth)->PV;
4254     } elsif ($meth->name eq "method_redir_super") {
4255         $meth = $self->meth_rclass_sv($meth)->PV.'::SUPER::'.
4256                 $self->meth_sv($meth)->PV;
4257     } else {
4258         $meth = $meth->first;
4259         if ($meth->name eq "const") {
4260             # As of 5.005_58, this case is probably obsoleted by the
4261             # method_named case above
4262             $meth = $self->const_sv($meth)->PV; # needs to be bare
4263         }
4264     }
4265
4266     return { method => $meth, variable_method => ref($meth),
4267              object => $obj, args => \@exprs  },
4268            $cx;
4269 }
4270
4271 # compat function only
4272 sub method {
4273     my $self = shift;
4274     my $info = $self->_method(@_);
4275     return $self->e_method( $self->_method(@_) );
4276 }
4277
4278 sub e_method {
4279     my ($self, $info, $cx) = @_;
4280     my $obj = $self->deparse($info->{object}, 24);
4281
4282     my $meth = $info->{method};
4283     $meth = $self->deparse($meth, 1) if $info->{variable_method};
4284     my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
4285     if ($info->{object}->name eq 'scope' && want_list $info->{object}) {
4286         # method { $object }
4287         # This must be deparsed this way to preserve list context
4288         # of $object.
4289         my $need_paren = $cx >= 6;
4290         return '(' x $need_paren
4291              . $meth . substr($obj,2) # chop off the "do"
4292              . " $args"
4293              . ')' x $need_paren;
4294     }
4295     my $kid = $obj . "->" . $meth;
4296     if (length $args) {
4297         return $kid . "(" . $args . ")"; # parens mandatory
4298     } else {
4299         return $kid;
4300     }
4301 }
4302
4303 # returns "&" if the prototype doesn't match the args,
4304 # or ("", $args_after_prototype_demunging) if it does.
4305 sub check_proto {
4306     my $self = shift;
4307     return "&" if $self->{'noproto'};
4308     my($proto, @args) = @_;
4309     my($arg, $real);
4310     my $doneok = 0;
4311     my @reals;
4312     # An unbackslashed @ or % gobbles up the rest of the args
4313     1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
4314     $proto =~ s/^\s*//;
4315     while ($proto) {
4316         $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;|)\s*//;
4317         my $chr = $1;
4318         if ($chr eq "") {
4319             return "&" if @args;
4320         } elsif ($chr eq ";") {
4321             $doneok = 1;
4322         } elsif ($chr eq "@" or $chr eq "%") {
4323             push @reals, map($self->deparse($_, 6), @args);
4324             @args = ();
4325         } else {
4326             $arg = shift @args;
4327             last unless $arg;
4328             if ($chr eq "\$" || $chr eq "_") {
4329                 if (want_scalar $arg) {
4330                     push @reals, $self->deparse($arg, 6);
4331                 } else {
4332                     return "&";
4333                 }
4334             } elsif ($chr eq "&") {
4335                 if ($arg->name =~ /^(s?refgen|undef)$/) {
4336                     push @reals, $self->deparse($arg, 6);
4337                 } else {
4338                     return "&";
4339                 }
4340             } elsif ($chr eq "*") {
4341                 if ($arg->name =~ /^s?refgen$/
4342                     and $arg->first->first->name eq "rv2gv")
4343                   {
4344                       $real = $arg->first->first; # skip refgen, null
4345                       if ($real->first->name eq "gv") {
4346                           push @reals, $self->deparse($real, 6);
4347                       } else {
4348                           push @reals, $self->deparse($real->first, 6);
4349                       }
4350                   } else {
4351                       return "&";
4352                   }
4353             } elsif (substr($chr, 0, 1) eq "\\") {
4354                 $chr =~ tr/\\[]//d;
4355                 if ($arg->name =~ /^s?refgen$/ and
4356                     !null($real = $arg->first) and
4357                     ($chr =~ /\$/ && is_scalar($real->first)
4358                      or ($chr =~ /@/
4359                          && class($real->first->sibling) ne 'NULL'
4360                          && $real->first->sibling->name
4361                          =~ /^(rv2|pad)av$/)
4362                      or ($chr =~ /%/
4363                          && class($real->first->sibling) ne 'NULL'
4364                          && $real->first->sibling->name
4365                          =~ /^(rv2|pad)hv$/)
4366                      #or ($chr =~ /&/ # This doesn't work
4367                      #   && $real->first->name eq "rv2cv")
4368                      or ($chr =~ /\*/
4369                          && $real->first->name eq "rv2gv")))
4370                   {
4371                       push @reals, $self->deparse($real, 6);
4372                   } else {
4373                       return "&";
4374                   }
4375             }
4376        }
4377     }
4378     return "&" if $proto and !$doneok; # too few args and no ';'
4379     return "&" if @args;               # too many args
4380     return ("", join ", ", @reals);
4381 }
4382
4383 sub retscalar {
4384     my $name = $_[0]->name;
4385     # XXX There has to be a better way of doing this scalar-op check.
4386     #     Currently PL_opargs is not exposed.
4387     if ($name eq 'null') {
4388         $name = substr B::ppname($_[0]->targ), 3
4389     }
4390     $name =~ /^(?:scalar|pushmark|wantarray|const|gvsv|gv|padsv|rv2gv
4391                  |rv2sv|av2arylen|anoncode|prototype|srefgen|ref|bless
4392                  |regcmaybe|regcreset|regcomp|qr|subst|substcont|trans
4393                  |transr|sassign|chop|schop|chomp|schomp|defined|undef
4394                  |study|pos|preinc|i_preinc|predec|i_predec|postinc
4395                  |i_postinc|postdec|i_postdec|pow|multiply|i_multiply
4396                  |divide|i_divide|modulo|i_modulo|add|i_add|subtract
4397                  |i_subtract|concat|stringify|left_shift|right_shift|lt
4398                  |i_lt|gt|i_gt|le|i_le|ge|i_ge|eq|i_eq|ne|i_ne|ncmp|i_ncmp
4399                  |slt|sgt|sle|sge|seq|sne|scmp|[sn]?bit_(?:and|x?or)|negate
4400                  |i_negate|not|[sn]?complement|smartmatch|atan2|sin|cos
4401                  |rand|srand|exp|log|sqrt|int|hex|oct|abs|length|substr
4402                  |vec|index|rindex|sprintf|formline|ord|chr|crypt|ucfirst
4403                  |lcfirst|uc|lc|quotemeta|aelemfast|aelem|exists|helem
4404                  |pack|join|anonlist|anonhash|push|pop|shift|unshift|xor
4405                  |andassign|orassign|dorassign|warn|die|reset|nextstate
4406                  |dbstate|unstack|last|next|redo|dump|goto|exit|open|close
4407                  |pipe_op|fileno|umask|binmode|tie|untie|tied|dbmopen
4408                  |dbmclose|select|getc|read|enterwrite|prtf|print|say
4409                  |sysopen|sysseek|sysread|syswrite|eof|tell|seek|truncate
4410                  |fcntl|ioctl|flock|send|recv|socket|sockpair|bind|connect
4411                  |listen|accept|shutdown|gsockopt|ssockopt|getsockname
4412                  |getpeername|ftrread|ftrwrite|ftrexec|fteread|ftewrite
4413                  |fteexec|ftis|ftsize|ftmtime|ftatime|ftctime|ftrowned
4414                  |fteowned|ftzero|ftsock|ftchr|ftblk|ftfile|ftdir|ftpipe
4415                  |ftsuid|ftsgid|ftsvtx|ftlink|fttty|fttext|ftbinary|chdir
4416                  |chown|chroot|unlink|chmod|utime|rename|link|symlink
4417                  |readlink|mkdir|rmdir|open_dir|telldir|seekdir|rewinddir
4418                  |closedir|fork|wait|waitpid|system|exec|kill|getppid
4419                  |getpgrp|setpgrp|getpriority|setpriority|time|alarm|sleep
4420                  |shmget|shmctl|shmread|shmwrite|msgget|msgctl|msgsnd
4421                  |msgrcv|semop|semget|semctl|hintseval|shostent|snetent
4422                  |sprotoent|sservent|ehostent|enetent|eprotoent|eservent
4423                  |spwent|epwent|sgrent|egrent|getlogin|syscall|lock|runcv
4424                  |fc)\z/x
4425 }
4426
4427 sub pp_entersub {
4428     my $self = shift;
4429     my($op, $cx) = @_;
4430     return $self->e_method($self->_method($op, $cx))
4431         unless null $op->first->sibling;
4432     my $prefix = "";
4433     my $amper = "";
4434     my($kid, @exprs);
4435     if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
4436         $prefix = "do ";
4437     } elsif ($op->private & OPpENTERSUB_AMPER) {
4438         $amper = "&";
4439     }
4440     $kid = $op->first;
4441     $kid = $kid->first->sibling; # skip ex-list, pushmark
4442     for (; not null $kid->sibling; $kid = $kid->sibling) {
4443         push @exprs, $kid;
4444     }
4445     my $simple = 0;
4446     my $proto = undef;
4447     my $lexical;
4448     if (is_scope($kid)) {
4449         $amper = "&";
4450         $kid = "{" . $self->deparse($kid, 0) . "}";
4451     } elsif ($kid->first->name eq "gv") {
4452         my $gv = $self->gv_or_padgv($kid->first);
4453         my $cv;
4454         if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL"
4455          || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') {
4456             $proto = $cv->PV if $cv->FLAGS & SVf_POK;
4457         }