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