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