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