Deparse inlined constants.
[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         if (defined prototype("CORE::$name")
1607            && prototype("CORE::$name") =~ /^;?\*/
1608            && $kid->name eq "rv2gv") {
1609             $kid = $kid->first;
1610         }
1611
1612         return $self->maybe_parens_unop($name, $kid, $cx);
1613     } else {
1614         return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");
1615     }
1616 }
1617
1618 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1619 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1620 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1621 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1622 sub pp_defined { unop(@_, "defined") }
1623 sub pp_undef { unop(@_, "undef") }
1624 sub pp_study { unop(@_, "study") }
1625 sub pp_ref { unop(@_, "ref") }
1626 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1627
1628 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1629 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1630 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1631 sub pp_srand { unop(@_, "srand") }
1632 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1633 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1634 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1635 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1636 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1637 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1638 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1639
1640 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1641 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1642 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1643
1644 sub pp_each { unop(@_, "each") }
1645 sub pp_values { unop(@_, "values") }
1646 sub pp_keys { unop(@_, "keys") }
1647 sub pp_aeach { unop(@_, "each") }
1648 sub pp_avalues { unop(@_, "values") }
1649 sub pp_akeys { unop(@_, "keys") }
1650 sub pp_pop { unop(@_, "pop") }
1651 sub pp_shift { unop(@_, "shift") }
1652
1653 sub pp_caller { unop(@_, "caller") }
1654 sub pp_reset { unop(@_, "reset") }
1655 sub pp_exit { unop(@_, "exit") }
1656 sub pp_prototype { unop(@_, "prototype") }
1657
1658 sub pp_close { unop(@_, "close") }
1659 sub pp_fileno { unop(@_, "fileno") }
1660 sub pp_umask { unop(@_, "umask") }
1661 sub pp_untie { unop(@_, "untie") }
1662 sub pp_tied { unop(@_, "tied") }
1663 sub pp_dbmclose { unop(@_, "dbmclose") }
1664 sub pp_getc { unop(@_, "getc") }
1665 sub pp_eof { unop(@_, "eof") }
1666 sub pp_tell { unop(@_, "tell") }
1667 sub pp_getsockname { unop(@_, "getsockname") }
1668 sub pp_getpeername { unop(@_, "getpeername") }
1669
1670 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1671 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1672 sub pp_readlink { unop(@_, "readlink") }
1673 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1674 sub pp_readdir { unop(@_, "readdir") }
1675 sub pp_telldir { unop(@_, "telldir") }
1676 sub pp_rewinddir { unop(@_, "rewinddir") }
1677 sub pp_closedir { unop(@_, "closedir") }
1678 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1679 sub pp_localtime { unop(@_, "localtime") }
1680 sub pp_gmtime { unop(@_, "gmtime") }
1681 sub pp_alarm { unop(@_, "alarm") }
1682 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1683
1684 sub pp_dofile { unop(@_, "do") }
1685 sub pp_entereval { unop(@_, "eval") }
1686
1687 sub pp_ghbyname { unop(@_, "gethostbyname") }
1688 sub pp_gnbyname { unop(@_, "getnetbyname") }
1689 sub pp_gpbyname { unop(@_, "getprotobyname") }
1690 sub pp_shostent { unop(@_, "sethostent") }
1691 sub pp_snetent { unop(@_, "setnetent") }
1692 sub pp_sprotoent { unop(@_, "setprotoent") }
1693 sub pp_sservent { unop(@_, "setservent") }
1694 sub pp_gpwnam { unop(@_, "getpwnam") }
1695 sub pp_gpwuid { unop(@_, "getpwuid") }
1696 sub pp_ggrnam { unop(@_, "getgrnam") }
1697 sub pp_ggrgid { unop(@_, "getgrgid") }
1698
1699 sub pp_lock { unop(@_, "lock") }
1700
1701 sub pp_continue { unop(@_, "continue"); }
1702 sub pp_break {
1703     my ($self, $op) = @_;
1704     return "" if $op->flags & OPf_SPECIAL;
1705     unop(@_, "break");
1706 }
1707
1708 sub givwhen {
1709     my $self = shift;
1710     my($op, $cx, $givwhen) = @_;
1711
1712     my $enterop = $op->first;
1713     my ($head, $block);
1714     if ($enterop->flags & OPf_SPECIAL) {
1715         $head = "default";
1716         $block = $self->deparse($enterop->first, 0);
1717     }
1718     else {
1719         my $cond = $enterop->first;
1720         my $cond_str = $self->deparse($cond, 1);
1721         $head = "$givwhen ($cond_str)";
1722         $block = $self->deparse($cond->sibling, 0);
1723     }
1724
1725     return "$head {\n".
1726         "\t$block\n".
1727         "\b}\cK";
1728 }
1729
1730 sub pp_leavegiven { givwhen(@_, "given"); }
1731 sub pp_leavewhen  { givwhen(@_, "when"); }
1732
1733 sub pp_exists {
1734     my $self = shift;
1735     my($op, $cx) = @_;
1736     my $arg;
1737     if ($op->private & OPpEXISTS_SUB) {
1738         # Checking for the existence of a subroutine
1739         return $self->maybe_parens_func("exists",
1740                                 $self->pp_rv2cv($op->first, 16), $cx, 16);
1741     }
1742     if ($op->flags & OPf_SPECIAL) {
1743         # Array element, not hash element
1744         return $self->maybe_parens_func("exists",
1745                                 $self->pp_aelem($op->first, 16), $cx, 16);
1746     }
1747     return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1748                                     $cx, 16);
1749 }
1750
1751 sub pp_delete {
1752     my $self = shift;
1753     my($op, $cx) = @_;
1754     my $arg;
1755     if ($op->private & OPpSLICE) {
1756         if ($op->flags & OPf_SPECIAL) {
1757             # Deleting from an array, not a hash
1758             return $self->maybe_parens_func("delete",
1759                                         $self->pp_aslice($op->first, 16),
1760                                         $cx, 16);
1761         }
1762         return $self->maybe_parens_func("delete",
1763                                         $self->pp_hslice($op->first, 16),
1764                                         $cx, 16);
1765     } else {
1766         if ($op->flags & OPf_SPECIAL) {
1767             # Deleting from an array, not a hash
1768             return $self->maybe_parens_func("delete",
1769                                         $self->pp_aelem($op->first, 16),
1770                                         $cx, 16);
1771         }
1772         return $self->maybe_parens_func("delete",
1773                                         $self->pp_helem($op->first, 16),
1774                                         $cx, 16);
1775     }
1776 }
1777
1778 sub pp_require {
1779     my $self = shift;
1780     my($op, $cx) = @_;
1781     my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
1782     if (class($op) eq "UNOP" and $op->first->name eq "const"
1783         and $op->first->private & OPpCONST_BARE)
1784     {
1785         my $name = $self->const_sv($op->first)->PV;
1786         $name =~ s[/][::]g;
1787         $name =~ s/\.pm//g;
1788         return "$opname $name";
1789     } else {    
1790         $self->unop($op, $cx, $opname);
1791     }
1792 }
1793
1794 sub pp_scalar {
1795     my $self = shift;
1796     my($op, $cx) = @_;
1797     my $kid = $op->first;
1798     if (not null $kid->sibling) {
1799         # XXX Was a here-doc
1800         return $self->dquote($op);
1801     }
1802     $self->unop(@_, "scalar");
1803 }
1804
1805
1806 sub padval {
1807     my $self = shift;
1808     my $targ = shift;
1809     return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
1810 }
1811
1812 sub anon_hash_or_list {
1813     my $self = shift;
1814     my($op, $cx) = @_;
1815
1816     my($pre, $post) = @{{"anonlist" => ["[","]"],
1817                          "anonhash" => ["{","}"]}->{$op->name}};
1818     my($expr, @exprs);
1819     $op = $op->first->sibling; # skip pushmark
1820     for (; !null($op); $op = $op->sibling) {
1821         $expr = $self->deparse($op, 6);
1822         push @exprs, $expr;
1823     }
1824     if ($pre eq "{" and $cx < 1) {
1825         # Disambiguate that it's not a block
1826         $pre = "+{";
1827     }
1828     return $pre . join(", ", @exprs) . $post;
1829 }
1830
1831 sub pp_anonlist {
1832     my $self = shift;
1833     my ($op, $cx) = @_;
1834     if ($op->flags & OPf_SPECIAL) {
1835         return $self->anon_hash_or_list($op, $cx);
1836     }
1837     warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL";
1838     return 'XXX';
1839 }
1840
1841 *pp_anonhash = \&pp_anonlist;
1842
1843 sub pp_refgen {
1844     my $self = shift;   
1845     my($op, $cx) = @_;
1846     my $kid = $op->first;
1847     if ($kid->name eq "null") {
1848         $kid = $kid->first;
1849         if (!null($kid->sibling) and
1850                  $kid->sibling->name eq "anoncode") {
1851             return $self->e_anoncode({ code => $self->padval($kid->sibling->targ) });
1852         } elsif ($kid->name eq "pushmark") {
1853             my $sib_name = $kid->sibling->name;
1854             if ($sib_name =~ /^(pad|rv2)[ah]v$/
1855                 and not $kid->sibling->flags & OPf_REF)
1856             {
1857                 # The @a in \(@a) isn't in ref context, but only when the
1858                 # parens are there.
1859                 return "\\(" . $self->pp_list($op->first) . ")";
1860             } elsif ($sib_name eq 'entersub') {
1861                 my $text = $self->deparse($kid->sibling, 1);
1862                 # Always show parens for \(&func()), but only with -p otherwise
1863                 $text = "($text)" if $self->{'parens'}
1864                                  or $kid->sibling->private & OPpENTERSUB_AMPER;
1865                 return "\\$text";
1866             }
1867         }
1868     }
1869     $self->pfixop($op, $cx, "\\", 20);
1870 }
1871
1872 sub e_anoncode {
1873     my ($self, $info) = @_;
1874     my $text = $self->deparse_sub($info->{code});
1875     return "sub " . $text;
1876 }
1877
1878 sub pp_srefgen { pp_refgen(@_) }
1879
1880 sub pp_readline {
1881     my $self = shift;
1882     my($op, $cx) = @_;
1883     my $kid = $op->first;
1884     $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1885     return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
1886     return $self->unop($op, $cx, "readline");
1887 }
1888
1889 sub pp_rcatline {
1890     my $self = shift;
1891     my($op) = @_;
1892     return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
1893 }
1894
1895 # Unary operators that can occur as pseudo-listops inside double quotes
1896 sub dq_unop {
1897     my $self = shift;
1898     my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1899     my $kid;
1900     if ($op->flags & OPf_KIDS) {
1901        $kid = $op->first;
1902        # If there's more than one kid, the first is an ex-pushmark.
1903        $kid = $kid->sibling if not null $kid->sibling;
1904        return $self->maybe_parens_unop($name, $kid, $cx);
1905     } else {
1906        return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");
1907     }
1908 }
1909
1910 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1911 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1912 sub pp_uc { dq_unop(@_, "uc") }
1913 sub pp_lc { dq_unop(@_, "lc") }
1914 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1915
1916 sub loopex {
1917     my $self = shift;
1918     my ($op, $cx, $name) = @_;
1919     if (class($op) eq "PVOP") {
1920         return "$name " . $op->pv;
1921     } elsif (class($op) eq "OP") {
1922         return $name;
1923     } elsif (class($op) eq "UNOP") {
1924         # Note -- loop exits are actually exempt from the
1925         # looks-like-a-func rule, but a few extra parens won't hurt
1926         return $self->maybe_parens_unop($name, $op->first, $cx);
1927     }
1928 }
1929
1930 sub pp_last { loopex(@_, "last") }
1931 sub pp_next { loopex(@_, "next") }
1932 sub pp_redo { loopex(@_, "redo") }
1933 sub pp_goto { loopex(@_, "goto") }
1934 sub pp_dump { loopex(@_, "dump") }
1935
1936 sub ftst {
1937     my $self = shift;
1938     my($op, $cx, $name) = @_;
1939     if (class($op) eq "UNOP") {
1940         # Genuine `-X' filetests are exempt from the LLAFR, but not
1941         # l?stat(); for the sake of clarity, give'em all parens
1942         return $self->maybe_parens_unop($name, $op->first, $cx);
1943     } elsif (class($op) =~ /^(SV|PAD)OP$/) {
1944         return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1945     } else { # I don't think baseop filetests ever survive ck_ftst, but...
1946         return $name;
1947     }
1948 }
1949
1950 sub pp_lstat    { ftst(@_, "lstat") }
1951 sub pp_stat     { ftst(@_, "stat") }
1952 sub pp_ftrread  { ftst(@_, "-R") }
1953 sub pp_ftrwrite { ftst(@_, "-W") }
1954 sub pp_ftrexec  { ftst(@_, "-X") }
1955 sub pp_fteread  { ftst(@_, "-r") }
1956 sub pp_ftewrite { ftst(@_, "-w") }
1957 sub pp_fteexec  { ftst(@_, "-x") }
1958 sub pp_ftis     { ftst(@_, "-e") }
1959 sub pp_fteowned { ftst(@_, "-O") }
1960 sub pp_ftrowned { ftst(@_, "-o") }
1961 sub pp_ftzero   { ftst(@_, "-z") }
1962 sub pp_ftsize   { ftst(@_, "-s") }
1963 sub pp_ftmtime  { ftst(@_, "-M") }
1964 sub pp_ftatime  { ftst(@_, "-A") }
1965 sub pp_ftctime  { ftst(@_, "-C") }
1966 sub pp_ftsock   { ftst(@_, "-S") }
1967 sub pp_ftchr    { ftst(@_, "-c") }
1968 sub pp_ftblk    { ftst(@_, "-b") }
1969 sub pp_ftfile   { ftst(@_, "-f") }
1970 sub pp_ftdir    { ftst(@_, "-d") }
1971 sub pp_ftpipe   { ftst(@_, "-p") }
1972 sub pp_ftlink   { ftst(@_, "-l") }
1973 sub pp_ftsuid   { ftst(@_, "-u") }
1974 sub pp_ftsgid   { ftst(@_, "-g") }
1975 sub pp_ftsvtx   { ftst(@_, "-k") }
1976 sub pp_fttty    { ftst(@_, "-t") }
1977 sub pp_fttext   { ftst(@_, "-T") }
1978 sub pp_ftbinary { ftst(@_, "-B") }
1979
1980 sub SWAP_CHILDREN () { 1 }
1981 sub ASSIGN () { 2 } # has OP= variant
1982 sub LIST_CONTEXT () { 4 } # Assignment is in list context
1983
1984 my(%left, %right);
1985
1986 sub assoc_class {
1987     my $op = shift;
1988     my $name = $op->name;
1989     if ($name eq "concat" and $op->first->name eq "concat") {
1990         # avoid spurious `=' -- see comment in pp_concat
1991         return "concat";
1992     }
1993     if ($name eq "null" and class($op) eq "UNOP"
1994         and $op->first->name =~ /^(and|x?or)$/
1995         and null $op->first->sibling)
1996     {
1997         # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1998         # with a null that's used as the common end point of the two
1999         # flows of control. For precedence purposes, ignore it.
2000         # (COND_EXPRs have these too, but we don't bother with
2001         # their associativity).
2002         return assoc_class($op->first);
2003     }
2004     return $name . ($op->flags & OPf_STACKED ? "=" : "");
2005 }
2006
2007 # Left associative operators, like `+', for which
2008 # $a + $b + $c is equivalent to ($a + $b) + $c
2009
2010 BEGIN {
2011     %left = ('multiply' => 19, 'i_multiply' => 19,
2012              'divide' => 19, 'i_divide' => 19,
2013              'modulo' => 19, 'i_modulo' => 19,
2014              'repeat' => 19,
2015              'add' => 18, 'i_add' => 18,
2016              'subtract' => 18, 'i_subtract' => 18,
2017              'concat' => 18,
2018              'left_shift' => 17, 'right_shift' => 17,
2019              'bit_and' => 13,
2020              'bit_or' => 12, 'bit_xor' => 12,
2021              'and' => 3,
2022              'or' => 2, 'xor' => 2,
2023             );
2024 }
2025
2026 sub deparse_binop_left {
2027     my $self = shift;
2028     my($op, $left, $prec) = @_;
2029     if ($left{assoc_class($op)} && $left{assoc_class($left)}
2030         and $left{assoc_class($op)} == $left{assoc_class($left)})
2031     {
2032         return $self->deparse($left, $prec - .00001);
2033     } else {
2034         return $self->deparse($left, $prec);    
2035     }
2036 }
2037
2038 # Right associative operators, like `=', for which
2039 # $a = $b = $c is equivalent to $a = ($b = $c)
2040
2041 BEGIN {
2042     %right = ('pow' => 22,
2043               'sassign=' => 7, 'aassign=' => 7,
2044               'multiply=' => 7, 'i_multiply=' => 7,
2045               'divide=' => 7, 'i_divide=' => 7,
2046               'modulo=' => 7, 'i_modulo=' => 7,
2047               'repeat=' => 7,
2048               'add=' => 7, 'i_add=' => 7,
2049               'subtract=' => 7, 'i_subtract=' => 7,
2050               'concat=' => 7,
2051               'left_shift=' => 7, 'right_shift=' => 7,
2052               'bit_and=' => 7,
2053               'bit_or=' => 7, 'bit_xor=' => 7,
2054               'andassign' => 7,
2055               'orassign' => 7,
2056              );
2057 }
2058
2059 sub deparse_binop_right {
2060     my $self = shift;
2061     my($op, $right, $prec) = @_;
2062     if ($right{assoc_class($op)} && $right{assoc_class($right)}
2063         and $right{assoc_class($op)} == $right{assoc_class($right)})
2064     {
2065         return $self->deparse($right, $prec - .00001);
2066     } else {
2067         return $self->deparse($right, $prec);   
2068     }
2069 }
2070
2071 sub binop {
2072     my $self = shift;
2073     my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
2074     my $left = $op->first;
2075     my $right = $op->last;
2076     my $eq = "";
2077     if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
2078         $eq = "=";
2079         $prec = 7;
2080     }
2081     if ($flags & SWAP_CHILDREN) {
2082         ($left, $right) = ($right, $left);
2083     }
2084     $left = $self->deparse_binop_left($op, $left, $prec);
2085     $left = "($left)" if $flags & LIST_CONTEXT
2086                 && $left !~ /^(my|our|local|)[\@\(]/;
2087     $right = $self->deparse_binop_right($op, $right, $prec);
2088     return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
2089 }
2090
2091 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2092 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2093 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18,  ASSIGN) }
2094 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2095 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2096 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2097 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2098 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
2099 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2100 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2101 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
2102
2103 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
2104 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
2105 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
2106 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
2107 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
2108
2109 sub pp_eq { binop(@_, "==", 14) }
2110 sub pp_ne { binop(@_, "!=", 14) }
2111 sub pp_lt { binop(@_, "<", 15) }
2112 sub pp_gt { binop(@_, ">", 15) }
2113 sub pp_ge { binop(@_, ">=", 15) }
2114 sub pp_le { binop(@_, "<=", 15) }
2115 sub pp_ncmp { binop(@_, "<=>", 14) }
2116 sub pp_i_eq { binop(@_, "==", 14) }
2117 sub pp_i_ne { binop(@_, "!=", 14) }
2118 sub pp_i_lt { binop(@_, "<", 15) }
2119 sub pp_i_gt { binop(@_, ">", 15) }
2120 sub pp_i_ge { binop(@_, ">=", 15) }
2121 sub pp_i_le { binop(@_, "<=", 15) }
2122 sub pp_i_ncmp { binop(@_, "<=>", 14) }
2123
2124 sub pp_seq { binop(@_, "eq", 14) }
2125 sub pp_sne { binop(@_, "ne", 14) }
2126 sub pp_slt { binop(@_, "lt", 15) }
2127 sub pp_sgt { binop(@_, "gt", 15) }
2128 sub pp_sge { binop(@_, "ge", 15) }
2129 sub pp_sle { binop(@_, "le", 15) }
2130 sub pp_scmp { binop(@_, "cmp", 14) }
2131
2132 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
2133 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
2134
2135 sub pp_smartmatch {
2136     my ($self, $op, $cx) = @_;
2137     if ($op->flags & OPf_SPECIAL) {
2138         return $self->deparse($op->last, $cx);
2139     }
2140     else {
2141         binop(@_, "~~", 14);
2142     }
2143 }
2144
2145 # `.' is special because concats-of-concats are optimized to save copying
2146 # by making all but the first concat stacked. The effect is as if the
2147 # programmer had written `($a . $b) .= $c', except legal.
2148 sub pp_concat { maybe_targmy(@_, \&real_concat) }
2149 sub real_concat {
2150     my $self = shift;
2151     my($op, $cx) = @_;
2152     my $left = $op->first;
2153     my $right = $op->last;
2154     my $eq = "";
2155     my $prec = 18;
2156     if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
2157         $eq = "=";
2158         $prec = 7;
2159     }
2160     $left = $self->deparse_binop_left($op, $left, $prec);
2161     $right = $self->deparse_binop_right($op, $right, $prec);
2162     return $self->maybe_parens("$left .$eq $right", $cx, $prec);
2163 }
2164
2165 # `x' is weird when the left arg is a list
2166 sub pp_repeat {
2167     my $self = shift;
2168     my($op, $cx) = @_;
2169     my $left = $op->first;
2170     my $right = $op->last;
2171     my $eq = "";
2172     my $prec = 19;
2173     if ($op->flags & OPf_STACKED) {
2174         $eq = "=";
2175         $prec = 7;
2176     }
2177     if (null($right)) { # list repeat; count is inside left-side ex-list
2178         my $kid = $left->first->sibling; # skip pushmark
2179         my @exprs;
2180         for (; !null($kid->sibling); $kid = $kid->sibling) {
2181             push @exprs, $self->deparse($kid, 6);
2182         }
2183         $right = $kid;
2184         $left = "(" . join(", ", @exprs). ")";
2185     } else {
2186         $left = $self->deparse_binop_left($op, $left, $prec);
2187     }
2188     $right = $self->deparse_binop_right($op, $right, $prec);
2189     return $self->maybe_parens("$left x$eq $right", $cx, $prec);
2190 }
2191
2192 sub range {
2193     my $self = shift;
2194     my ($op, $cx, $type) = @_;
2195     my $left = $op->first;
2196     my $right = $left->sibling;
2197     $left = $self->deparse($left, 9);
2198     $right = $self->deparse($right, 9);
2199     return $self->maybe_parens("$left $type $right", $cx, 9);
2200 }
2201
2202 sub pp_flop {
2203     my $self = shift;
2204     my($op, $cx) = @_;
2205     my $flip = $op->first;
2206     my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
2207     return $self->range($flip->first, $cx, $type);
2208 }
2209
2210 # one-line while/until is handled in pp_leave
2211
2212 sub logop {
2213     my $self = shift;
2214     my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
2215     my $left = $op->first;
2216     my $right = $op->first->sibling;
2217     if ($cx < 1 and is_scope($right) and $blockname
2218         and $self->{'expand'} < 7)
2219     { # if ($a) {$b}
2220         $left = $self->deparse($left, 1);
2221         $right = $self->deparse($right, 0);
2222         return "$blockname ($left) {\n\t$right\n\b}\cK";
2223     } elsif ($cx < 1 and $blockname and not $self->{'parens'}
2224              and $self->{'expand'} < 7) { # $b if $a
2225         $right = $self->deparse($right, 1);
2226         $left = $self->deparse($left, 1);
2227         return "$right $blockname $left";
2228     } elsif ($cx > $lowprec and $highop) { # $a && $b
2229         $left = $self->deparse_binop_left($op, $left, $highprec);
2230         $right = $self->deparse_binop_right($op, $right, $highprec);
2231         return $self->maybe_parens("$left $highop $right", $cx, $highprec);
2232     } else { # $a and $b
2233         $left = $self->deparse_binop_left($op, $left, $lowprec);
2234         $right = $self->deparse_binop_right($op, $right, $lowprec);
2235         return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
2236     }
2237 }
2238
2239 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
2240 sub pp_or  { logop(@_, "or",  2, "||", 10, "unless") }
2241 sub pp_dor { logop(@_, "err", 2, "//", 10, "") }
2242
2243 # xor is syntactically a logop, but it's really a binop (contrary to
2244 # old versions of opcode.pl). Syntax is what matters here.
2245 sub pp_xor { logop(@_, "xor", 2, "",   0,  "") }
2246
2247 sub logassignop {
2248     my $self = shift;
2249     my ($op, $cx, $opname) = @_;
2250     my $left = $op->first;
2251     my $right = $op->first->sibling->first; # skip sassign
2252     $left = $self->deparse($left, 7);
2253     $right = $self->deparse($right, 7);
2254     return $self->maybe_parens("$left $opname $right", $cx, 7);
2255 }
2256
2257 sub pp_andassign { logassignop(@_, "&&=") }
2258 sub pp_orassign  { logassignop(@_, "||=") }
2259 sub pp_dorassign { logassignop(@_, "//=") }
2260
2261 sub listop {
2262     my $self = shift;
2263     my($op, $cx, $name) = @_;
2264     my(@exprs);
2265     my $parens = ($cx >= 5) || $self->{'parens'};
2266     my $kid = $op->first->sibling;
2267     return $name if null $kid;
2268     my $first;
2269     $name = "socketpair" if $name eq "sockpair";
2270     my $proto = prototype("CORE::$name");
2271     if (defined $proto
2272         && $proto =~ /^;?\*/
2273         && $kid->name eq "rv2gv") {
2274         $first = $self->deparse($kid->first, 6);
2275     }
2276     else {
2277         $first = $self->deparse($kid, 6);
2278     }
2279     if ($name eq "chmod" && $first =~ /^\d+$/) {
2280         $first = sprintf("%#o", $first);
2281     }
2282     $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
2283     push @exprs, $first;
2284     $kid = $kid->sibling;
2285     if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") {
2286         push @exprs, $self->deparse($kid->first, 6);
2287         $kid = $kid->sibling;
2288     }
2289     for (; !null($kid); $kid = $kid->sibling) {
2290         push @exprs, $self->deparse($kid, 6);
2291     }
2292     if ($parens) {
2293         return "$name(" . join(", ", @exprs) . ")";
2294     } else {
2295         return "$name " . join(", ", @exprs);
2296     }
2297 }
2298
2299 sub pp_bless { listop(@_, "bless") }
2300 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
2301 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
2302 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
2303 sub pp_index { maybe_targmy(@_, \&listop, "index") }
2304 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
2305 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
2306 sub pp_formline { listop(@_, "formline") } # see also deparse_format
2307 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
2308 sub pp_unpack { listop(@_, "unpack") }
2309 sub pp_pack { listop(@_, "pack") }
2310 sub pp_join { maybe_targmy(@_, \&listop, "join") }
2311 sub pp_splice { listop(@_, "splice") }
2312 sub pp_push { maybe_targmy(@_, \&listop, "push") }
2313 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
2314 sub pp_reverse { listop(@_, "reverse") }
2315 sub pp_warn { listop(@_, "warn") }
2316 sub pp_die { listop(@_, "die") }
2317 # Actually, return is exempt from the LLAFR (see examples in this very
2318 # module!), but for consistency's sake, ignore that fact
2319 sub pp_return { listop(@_, "return") }
2320 sub pp_open { listop(@_, "open") }
2321 sub pp_pipe_op { listop(@_, "pipe") }
2322 sub pp_tie { listop(@_, "tie") }
2323 sub pp_binmode { listop(@_, "binmode") }
2324 sub pp_dbmopen { listop(@_, "dbmopen") }
2325 sub pp_sselect { listop(@_, "select") }
2326 sub pp_select { listop(@_, "select") }
2327 sub pp_read { listop(@_, "read") }
2328 sub pp_sysopen { listop(@_, "sysopen") }
2329 sub pp_sysseek { listop(@_, "sysseek") }
2330 sub pp_sysread { listop(@_, "sysread") }
2331 sub pp_syswrite { listop(@_, "syswrite") }
2332 sub pp_send { listop(@_, "send") }
2333 sub pp_recv { listop(@_, "recv") }
2334 sub pp_seek { listop(@_, "seek") }
2335 sub pp_fcntl { listop(@_, "fcntl") }
2336 sub pp_ioctl { listop(@_, "ioctl") }
2337 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
2338 sub pp_socket { listop(@_, "socket") }
2339 sub pp_sockpair { listop(@_, "sockpair") }
2340 sub pp_bind { listop(@_, "bind") }
2341 sub pp_connect { listop(@_, "connect") }
2342 sub pp_listen { listop(@_, "listen") }
2343 sub pp_accept { listop(@_, "accept") }
2344 sub pp_shutdown { listop(@_, "shutdown") }
2345 sub pp_gsockopt { listop(@_, "getsockopt") }
2346 sub pp_ssockopt { listop(@_, "setsockopt") }
2347 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
2348 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
2349 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
2350 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
2351 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
2352 sub pp_link { maybe_targmy(@_, \&listop, "link") }
2353 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
2354 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
2355 sub pp_open_dir { listop(@_, "opendir") }
2356 sub pp_seekdir { listop(@_, "seekdir") }
2357 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
2358 sub pp_system { maybe_targmy(@_, \&listop, "system") }
2359 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
2360 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
2361 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
2362 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
2363 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
2364 sub pp_shmget { listop(@_, "shmget") }
2365 sub pp_shmctl { listop(@_, "shmctl") }
2366 sub pp_shmread { listop(@_, "shmread") }
2367 sub pp_shmwrite { listop(@_, "shmwrite") }
2368 sub pp_msgget { listop(@_, "msgget") }
2369 sub pp_msgctl { listop(@_, "msgctl") }
2370 sub pp_msgsnd { listop(@_, "msgsnd") }
2371 sub pp_msgrcv { listop(@_, "msgrcv") }
2372 sub pp_semget { listop(@_, "semget") }
2373 sub pp_semctl { listop(@_, "semctl") }
2374 sub pp_semop { listop(@_, "semop") }
2375 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
2376 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
2377 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
2378 sub pp_gsbyname { listop(@_, "getservbyname") }
2379 sub pp_gsbyport { listop(@_, "getservbyport") }
2380 sub pp_syscall { listop(@_, "syscall") }
2381
2382 sub pp_glob {
2383     my $self = shift;
2384     my($op, $cx) = @_;
2385     my $text = $self->dq($op->first->sibling);  # skip pushmark
2386     if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
2387         or $text =~ /[<>]/) {
2388         return 'glob(' . single_delim('qq', '"', $text) . ')';
2389     } else {
2390         return '<' . $text . '>';
2391     }
2392 }
2393
2394 # Truncate is special because OPf_SPECIAL makes a bareword first arg
2395 # be a filehandle. This could probably be better fixed in the core
2396 # by moving the GV lookup into ck_truc.
2397
2398 sub pp_truncate {
2399     my $self = shift;
2400     my($op, $cx) = @_;
2401     my(@exprs);
2402     my $parens = ($cx >= 5) || $self->{'parens'};
2403     my $kid = $op->first->sibling;
2404     my $fh;
2405     if ($op->flags & OPf_SPECIAL) {
2406         # $kid is an OP_CONST
2407         $fh = $self->const_sv($kid)->PV;
2408     } else {
2409         $fh = $self->deparse($kid, 6);
2410         $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
2411     }
2412     my $len = $self->deparse($kid->sibling, 6);
2413     if ($parens) {
2414         return "truncate($fh, $len)";
2415     } else {
2416         return "truncate $fh, $len";
2417     }
2418 }
2419
2420 sub indirop {
2421     my $self = shift;
2422     my($op, $cx, $name) = @_;
2423     my($expr, @exprs);
2424     my $kid = $op->first->sibling;
2425     my $indir = "";
2426     if ($op->flags & OPf_STACKED) {
2427         $indir = $kid;
2428         $indir = $indir->first; # skip rv2gv
2429         if (is_scope($indir)) {
2430             $indir = "{" . $self->deparse($indir, 0) . "}";
2431             $indir = "{;}" if $indir eq "{}";
2432         } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
2433             $indir = $self->const_sv($indir)->PV;
2434         } else {
2435             $indir = $self->deparse($indir, 24);
2436         }
2437         $indir = $indir . " ";
2438         $kid = $kid->sibling;
2439     }
2440     if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
2441         $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
2442                                                   : '{$a <=> $b} ';
2443     }
2444     elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
2445         $indir = '{$b cmp $a} ';
2446     }
2447     for (; !null($kid); $kid = $kid->sibling) {
2448         $expr = $self->deparse($kid, 6);
2449         push @exprs, $expr;
2450     }
2451     my $name2 = $name;
2452     if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
2453         $name2 = 'reverse sort';
2454     }
2455     if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
2456         return "$exprs[0] = $name2 $indir $exprs[0]";
2457     }
2458
2459     my $args = $indir . join(", ", @exprs);
2460     if ($indir ne "" and $name eq "sort") {
2461         # We don't want to say "sort(f 1, 2, 3)", since perl -w will
2462         # give bareword warnings in that case. Therefore if context
2463         # requires, we'll put parens around the outside "(sort f 1, 2,
2464         # 3)". Unfortunately, we'll currently think the parens are
2465         # necessary more often that they really are, because we don't
2466         # distinguish which side of an assignment we're on.
2467         if ($cx >= 5) {
2468             return "($name2 $args)";
2469         } else {
2470             return "$name2 $args";
2471         }
2472     } else {
2473         return $self->maybe_parens_func($name2, $args, $cx, 5);
2474     }
2475
2476 }
2477
2478 sub pp_prtf { indirop(@_, "printf") }
2479 sub pp_print { indirop(@_, "print") }
2480 sub pp_say  { indirop(@_, "say") }
2481 sub pp_sort { indirop(@_, "sort") }
2482
2483 sub mapop {
2484     my $self = shift;
2485     my($op, $cx, $name) = @_;
2486     my($expr, @exprs);
2487     my $kid = $op->first; # this is the (map|grep)start
2488     $kid = $kid->first->sibling; # skip a pushmark
2489     my $code = $kid->first; # skip a null
2490     if (is_scope $code) {
2491         $code = "{" . $self->deparse($code, 0) . "} ";
2492     } else {
2493         $code = $self->deparse($code, 24) . ", ";
2494     }
2495     $kid = $kid->sibling;
2496     for (; !null($kid); $kid = $kid->sibling) {
2497         $expr = $self->deparse($kid, 6);
2498         push @exprs, $expr if defined $expr;
2499     }
2500     return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2501 }
2502
2503 sub pp_mapwhile { mapop(@_, "map") }
2504 sub pp_grepwhile { mapop(@_, "grep") }
2505 sub pp_mapstart { baseop(@_, "map") }
2506 sub pp_grepstart { baseop(@_, "grep") }
2507
2508 sub pp_list {
2509     my $self = shift;
2510     my($op, $cx) = @_;
2511     my($expr, @exprs);
2512     my $kid = $op->first->sibling; # skip pushmark
2513     my $lop;
2514     my $local = "either"; # could be local(...), my(...), state(...) or our(...)
2515     for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2516         # This assumes that no other private flags equal 128, and that
2517         # OPs that store things other than flags in their op_private,
2518         # like OP_AELEMFAST, won't be immediate children of a list.
2519         #
2520         # OP_ENTERSUB can break this logic, so check for it.
2521         # I suspect that open and exit can too.
2522
2523         if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
2524                 or $lop->name eq "undef")
2525             or $lop->name eq "entersub"
2526             or $lop->name eq "exit"
2527             or $lop->name eq "open")
2528         {
2529             $local = ""; # or not
2530             last;
2531         }
2532         if ($lop->name =~ /^pad[ash]v$/) {
2533             if ($lop->private & OPpPAD_STATE) { # state()
2534                 ($local = "", last) if $local =~ /^(?:local|our|my)$/;
2535                 $local = "state";
2536             } else { # my()
2537                 ($local = "", last) if $local =~ /^(?:local|our|state)$/;
2538                 $local = "my";
2539             }
2540         } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
2541                         && $lop->private & OPpOUR_INTRO
2542                 or $lop->name eq "null" && $lop->first->name eq "gvsv"
2543                         && $lop->first->private & OPpOUR_INTRO) { # our()
2544             ($local = "", last) if $local =~ /^(?:my|local|state)$/;
2545             $local = "our";
2546         } elsif ($lop->name ne "undef"
2547                 # specifically avoid the "reverse sort" optimisation,
2548                 # where "reverse" is nullified
2549                 && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
2550         {
2551             # local()
2552             ($local = "", last) if $local =~ /^(?:my|our|state)$/;
2553             $local = "local";
2554         }
2555     }
2556     $local = "" if $local eq "either"; # no point if it's all undefs
2557     return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2558     for (; !null($kid); $kid = $kid->sibling) {
2559         if ($local) {
2560             if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2561                 $lop = $kid->first;
2562             } else {
2563                 $lop = $kid;
2564             }
2565             $self->{'avoid_local'}{$$lop}++;
2566             $expr = $self->deparse($kid, 6);
2567             delete $self->{'avoid_local'}{$$lop};
2568         } else {
2569             $expr = $self->deparse($kid, 6);
2570         }
2571         push @exprs, $expr;
2572     }
2573     if ($local) {
2574         return "$local(" . join(", ", @exprs) . ")";
2575     } else {
2576         return $self->maybe_parens( join(", ", @exprs), $cx, 6);        
2577     }
2578 }
2579
2580 sub is_ifelse_cont {
2581     my $op = shift;
2582     return ($op->name eq "null" and class($op) eq "UNOP"
2583             and $op->first->name =~ /^(and|cond_expr)$/
2584             and is_scope($op->first->first->sibling));
2585 }
2586
2587 sub pp_cond_expr {
2588     my $self = shift;
2589     my($op, $cx) = @_;
2590     my $cond = $op->first;
2591     my $true = $cond->sibling;
2592     my $false = $true->sibling;
2593     my $cuddle = $self->{'cuddle'};
2594     unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
2595             (is_scope($false) || is_ifelse_cont($false))
2596             and $self->{'expand'} < 7) {
2597         $cond = $self->deparse($cond, 8);
2598         $true = $self->deparse($true, 6);
2599         $false = $self->deparse($false, 8);
2600         return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2601     }
2602
2603     $cond = $self->deparse($cond, 1);
2604     $true = $self->deparse($true, 0);
2605     my $head = "if ($cond) {\n\t$true\n\b}";
2606     my @elsifs;
2607     while (!null($false) and is_ifelse_cont($false)) {
2608         my $newop = $false->first;
2609         my $newcond = $newop->first;
2610         my $newtrue = $newcond->sibling;
2611         $false = $newtrue->sibling; # last in chain is OP_AND => no else
2612         if ($newcond->name eq "lineseq")
2613         {
2614             # lineseq to ensure correct line numbers in elsif()
2615             # Bug #37302 fixed by change #33710.
2616             $newcond = $newcond->first->sibling;
2617         }
2618         $newcond = $self->deparse($newcond, 1);
2619         $newtrue = $self->deparse($newtrue, 0);
2620         push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2621     }
2622     if (!null($false)) {
2623         $false = $cuddle . "else {\n\t" .
2624           $self->deparse($false, 0) . "\n\b}\cK";
2625     } else {
2626         $false = "\cK";
2627     }
2628     return $head . join($cuddle, "", @elsifs) . $false;
2629 }
2630
2631 sub pp_once {
2632     my ($self, $op, $cx) = @_;
2633     my $cond = $op->first;
2634     my $true = $cond->sibling;
2635
2636     return $self->deparse($true, $cx);
2637 }
2638
2639 sub loop_common {
2640     my $self = shift;
2641     my($op, $cx, $init) = @_;
2642     my $enter = $op->first;
2643     my $kid = $enter->sibling;
2644     local(@$self{qw'curstash warnings hints hinthash'})
2645                 = @$self{qw'curstash warnings hints hinthash'};
2646     my $head = "";
2647     my $bare = 0;
2648     my $body;
2649     my $cond = undef;
2650     if ($kid->name eq "lineseq") { # bare or infinite loop
2651         if ($kid->last->name eq "unstack") { # infinite
2652             $head = "while (1) "; # Can't use for(;;) if there's a continue
2653             $cond = "";
2654         } else {
2655             $bare = 1;
2656         }
2657         $body = $kid;
2658     } elsif ($enter->name eq "enteriter") { # foreach
2659         my $ary = $enter->first->sibling; # first was pushmark
2660         my $var = $ary->sibling;
2661         if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
2662             # "reverse" was optimised away
2663             $ary = listop($self, $ary->first->sibling, 1, 'reverse');
2664         } elsif ($enter->flags & OPf_STACKED
2665             and not null $ary->first->sibling->sibling)
2666         {
2667             $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2668               $self->deparse($ary->first->sibling->sibling, 9);
2669         } else {
2670             $ary = $self->deparse($ary, 1);
2671         }
2672         if (null $var) {
2673             if ($enter->flags & OPf_SPECIAL) { # thread special var
2674                 $var = $self->pp_threadsv($enter, 1);
2675             } else { # regular my() variable
2676                 $var = $self->pp_padsv($enter, 1);
2677             }
2678         } elsif ($var->name eq "rv2gv") {
2679             $var = $self->pp_rv2sv($var, 1);
2680             if ($enter->private & OPpOUR_INTRO) {
2681                 # our declarations don't have package names
2682                 $var =~ s/^(.).*::/$1/;
2683                 $var = "our $var";
2684             }
2685         } elsif ($var->name eq "gv") {
2686             $var = "\$" . $self->deparse($var, 1);
2687         }
2688         $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2689         if (!is_state $body->first and $body->first->name ne "stub") {
2690             confess unless $var eq '$_';
2691             $body = $body->first;
2692             return $self->deparse($body, 2) . " foreach ($ary)";
2693         }
2694         $head = "foreach $var ($ary) ";
2695     } elsif ($kid->name eq "null") { # while/until
2696         $kid = $kid->first;
2697         my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2698         $cond = $self->deparse($kid->first, 1);
2699         $head = "$name ($cond) ";
2700         $body = $kid->first->sibling;
2701     } elsif ($kid->name eq "stub") { # bare and empty
2702         return "{;}"; # {} could be a hashref
2703     }
2704     # If there isn't a continue block, then the next pointer for the loop
2705     # will point to the unstack, which is kid's last child, except
2706     # in a bare loop, when it will point to the leaveloop. When neither of
2707     # these conditions hold, then the second-to-last child is the continue
2708     # block (or the last in a bare loop).
2709     my $cont_start = $enter->nextop;
2710     my $cont;
2711     if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
2712         if ($bare) {
2713             $cont = $body->last;
2714         } else {
2715             $cont = $body->first;
2716             while (!null($cont->sibling->sibling)) {
2717                 $cont = $cont->sibling;
2718             }
2719         }
2720         my $state = $body->first;
2721         my $cuddle = $self->{'cuddle'};
2722         my @states;
2723         for (; $$state != $$cont; $state = $state->sibling) {
2724             push @states, $state;
2725         }
2726         $body = $self->lineseq(undef, @states);
2727         if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2728             $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2729             $cont = "\cK";
2730         } else {
2731             $cont = $cuddle . "continue {\n\t" .
2732               $self->deparse($cont, 0) . "\n\b}\cK";
2733         }
2734     } else {
2735         return "" if !defined $body;
2736         if (length $init) {
2737             $head = "for ($init; $cond;) ";
2738         }
2739         $cont = "\cK";
2740         $body = $self->deparse($body, 0);
2741     }
2742     $body =~ s/;?$/;\n/;
2743
2744     return $head . "{\n\t" . $body . "\b}" . $cont;
2745 }
2746
2747 sub pp_leaveloop { shift->loop_common(@_, "") }
2748
2749 sub for_loop {
2750     my $self = shift;
2751     my($op, $cx) = @_;
2752     my $init = $self->deparse($op, 1);
2753     return $self->loop_common($op->sibling->first->sibling, $cx, $init);
2754 }
2755
2756 sub pp_leavetry {
2757     my $self = shift;
2758     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2759 }
2760
2761 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2762 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2763 BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
2764 BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
2765
2766 sub pp_null {
2767     my $self = shift;
2768     my($op, $cx) = @_;
2769     if (class($op) eq "OP") {
2770         # old value is lost
2771         return $self->{'ex_const'} if $op->targ == OP_CONST;
2772     } elsif ($op->first->name eq "pushmark") {
2773         return $self->pp_list($op, $cx);
2774     } elsif ($op->first->name eq "enter") {
2775         return $self->pp_leave($op, $cx);
2776     } elsif ($op->first->name eq "leave") {
2777         return $self->pp_leave($op->first, $cx);
2778     } elsif ($op->first->name eq "scope") {
2779         return $self->pp_scope($op->first, $cx);
2780     } elsif ($op->targ == OP_STRINGIFY) {
2781         return $self->dquote($op, $cx);
2782     } elsif (!null($op->first->sibling) and
2783              $op->first->sibling->name eq "readline" and
2784              $op->first->sibling->flags & OPf_STACKED) {
2785         return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2786                                    . $self->deparse($op->first->sibling, 7),
2787                                    $cx, 7);
2788     } elsif (!null($op->first->sibling) and
2789              $op->first->sibling->name eq "trans" and
2790              $op->first->sibling->flags & OPf_STACKED) {
2791         return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2792                                    . $self->deparse($op->first->sibling, 20),
2793                                    $cx, 20);
2794     } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
2795         return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
2796     } elsif (!null($op->first->sibling) and
2797              $op->first->sibling->name eq "null" and
2798              class($op->first->sibling) eq "UNOP" and
2799              $op->first->sibling->first->flags & OPf_STACKED and
2800              $op->first->sibling->first->name eq "rcatline") {
2801         return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
2802                                    . $self->deparse($op->first->sibling, 18),
2803                                    $cx, 18);
2804     } else {
2805         return $self->deparse($op->first, $cx);
2806     }
2807 }
2808
2809 sub padname {
2810     my $self = shift;
2811     my $targ = shift;
2812     return $self->padname_sv($targ)->PVX;
2813 }
2814
2815 sub padany {
2816     my $self = shift;
2817     my $op = shift;
2818     return substr($self->padname($op->targ), 1); # skip $/@/%
2819 }
2820
2821 sub pp_padsv {
2822     my $self = shift;
2823     my($op, $cx) = @_;
2824     return $self->maybe_my($op, $cx, $self->padname($op->targ));
2825 }
2826
2827 sub pp_padav { pp_padsv(@_) }
2828 sub pp_padhv { pp_padsv(@_) }
2829
2830 my @threadsv_names;
2831
2832 BEGIN {
2833     @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2834                        "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2835                        "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2836                        "!", "@");
2837 }
2838
2839 sub pp_threadsv {
2840     my $self = shift;
2841     my($op, $cx) = @_;
2842     return $self->maybe_local($op, $cx, "\$" .  $threadsv_names[$op->targ]);
2843 }
2844
2845 sub gv_or_padgv {
2846     my $self = shift;
2847     my $op = shift;
2848     if (class($op) eq "PADOP") {
2849         return $self->padval($op->padix);
2850     } else { # class($op) eq "SVOP"
2851         return $op->gv;
2852     }
2853 }
2854
2855 sub pp_gvsv {
2856     my $self = shift;
2857     my($op, $cx) = @_;
2858     my $gv = $self->gv_or_padgv($op);
2859     return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2860                                  $self->gv_name($gv)));
2861 }
2862
2863 sub pp_gv {
2864     my $self = shift;
2865     my($op, $cx) = @_;
2866     my $gv = $self->gv_or_padgv($op);
2867     return $self->gv_name($gv);
2868 }
2869
2870 sub pp_aelemfast {
2871     my $self = shift;
2872     my($op, $cx) = @_;
2873     my $name;
2874     if ($op->flags & OPf_SPECIAL) { # optimised PADAV
2875         $name = $self->padname($op->targ);
2876         $name =~ s/^@/\$/;
2877     }
2878     else {
2879         my $gv = $self->gv_or_padgv($op);
2880         $name = $self->gv_name($gv);
2881         $name = $self->{'curstash'}."::$name"
2882             if $name !~ /::/ && $self->lex_in_scope('@'.$name);
2883         $name = '$' . $name;
2884     }
2885
2886     return $name . "[" .  ($op->private + $self->{'arybase'}) . "]";
2887 }
2888
2889 sub rv2x {
2890     my $self = shift;
2891     my($op, $cx, $type) = @_;
2892
2893     if (class($op) eq 'NULL' || !$op->can("first")) {
2894         carp("Unexpected op in pp_rv2x");
2895         return 'XXX';
2896     }
2897     my $kid = $op->first;
2898     if ($kid->name eq "gv") {
2899         return $self->stash_variable($type, $self->deparse($kid, 0));
2900     } elsif (is_scalar $kid) {
2901         my $str = $self->deparse($kid, 0);
2902         if ($str =~ /^\$([^\w\d])\z/) {
2903             # "$$+" isn't a legal way to write the scalar dereference
2904             # of $+, since the lexer can't tell you aren't trying to
2905             # do something like "$$ + 1" to get one more than your
2906             # PID. Either "${$+}" or "$${+}" are workable
2907             # disambiguations, but if the programmer did the former,
2908             # they'd be in the "else" clause below rather than here.
2909             # It's not clear if this should somehow be unified with
2910             # the code in dq and re_dq that also adds lexer
2911             # disambiguation braces.
2912             $str = '$' . "{$1}"; #'
2913         }
2914         return $type . $str;
2915     } else {
2916         return $type . "{" . $self->deparse($kid, 0) . "}";
2917     }
2918 }
2919
2920 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2921 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2922 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2923
2924 # skip rv2av
2925 sub pp_av2arylen {
2926     my $self = shift;
2927     my($op, $cx) = @_;
2928     if ($op->first->name eq "padav") {
2929         return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2930     } else {
2931         return $self->maybe_local($op, $cx,
2932                                   $self->rv2x($op->first, $cx, '$#'));
2933     }
2934 }
2935
2936 # skip down to the old, ex-rv2cv
2937 sub pp_rv2cv {
2938     my ($self, $op, $cx) = @_;
2939     if (!null($op->first) && $op->first->name eq 'null' &&
2940         $op->first->targ eq OP_LIST)
2941     {
2942         return $self->rv2x($op->first->first->sibling, $cx, "&")
2943     }
2944     else {
2945         return $self->rv2x($op, $cx, "")
2946     }
2947 }
2948
2949 sub list_const {
2950     my $self = shift;
2951     my($cx, @list) = @_;
2952     my @a = map $self->const($_, 6), @list;
2953     if (@a == 0) {
2954         return "()";
2955     } elsif (@a == 1) {
2956         return $a[0];
2957     } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
2958         # collapse (-1,0,1,2) into (-1..2)
2959         my ($s, $e) = @a[0,-1];
2960         my $i = $s;
2961         return $self->maybe_parens("$s..$e", $cx, 9)
2962           unless grep $i++ != $_, @a;
2963     }
2964     return $self->maybe_parens(join(", ", @a), $cx, 6);
2965 }
2966
2967 sub pp_rv2av {
2968     my $self = shift;
2969     my($op, $cx) = @_;
2970     my $kid = $op->first;
2971     if ($kid->name eq "const") { # constant list
2972         my $av = $self->const_sv($kid);
2973         return $self->list_const($cx, $av->ARRAY);
2974     } else {
2975         return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2976     }
2977  }
2978
2979 sub is_subscriptable {
2980     my $op = shift;
2981     if ($op->name =~ /^[ahg]elem/) {
2982         return 1;
2983     } elsif ($op->name eq "entersub") {
2984         my $kid = $op->first;
2985         return 0 unless null $kid->sibling;
2986         $kid = $kid->first;
2987         $kid = $kid->sibling until null $kid->sibling;
2988         return 0 if is_scope($kid);
2989         $kid = $kid->first;
2990         return 0 if $kid->name eq "gv";
2991         return 0 if is_scalar($kid);
2992         return is_subscriptable($kid);  
2993     } else {
2994         return 0;
2995     }
2996 }
2997
2998 sub elem_or_slice_array_name
2999 {
3000     my $self = shift;
3001     my ($array, $left, $padname, $allow_arrow) = @_;
3002
3003     if ($array->name eq $padname) {
3004         return $self->padany($array);
3005     } elsif (is_scope($array)) { # ${expr}[0]
3006         return "{" . $self->deparse($array, 0) . "}";
3007     } elsif ($array->name eq "gv") {
3008         $array = $self->gv_name($self->gv_or_padgv($array));
3009         if ($array !~ /::/) {
3010             my $prefix = ($left eq '[' ? '@' : '%');
3011             $array = $self->{curstash}.'::'.$array
3012                 if $self->lex_in_scope($prefix . $array);
3013         }
3014         return $array;
3015     } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
3016         return $self->deparse($array, 24);
3017     } else {
3018         return undef;
3019     }
3020 }
3021
3022 sub elem_or_slice_single_index
3023 {
3024     my $self = shift;
3025     my ($idx) = @_;
3026
3027     $idx = $self->deparse($idx, 1);
3028
3029     # Outer parens in an array index will confuse perl
3030     # if we're interpolating in a regular expression, i.e.
3031     # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
3032     #
3033     # If $self->{parens}, then an initial '(' will
3034     # definitely be paired with a final ')'. If
3035     # !$self->{parens}, the misleading parens won't
3036     # have been added in the first place.
3037     #
3038     # [You might think that we could get "(...)...(...)"
3039     # where the initial and final parens do not match
3040     # each other. But we can't, because the above would
3041     # only happen if there's an infix binop between the
3042     # two pairs of parens, and *that* means that the whole
3043     # expression would be parenthesized as well.]
3044     #
3045     $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
3046
3047     # Hash-element braces will autoquote a bareword inside themselves.
3048     # We need to make sure that C<$hash{warn()}> doesn't come out as
3049     # C<$hash{warn}>, which has a quite different meaning. Currently
3050     # B::Deparse will always quote strings, even if the string was a
3051     # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
3052     # for constant strings.) So we can cheat slightly here - if we see
3053     # a bareword, we know that it is supposed to be a function call.
3054     #
3055     $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
3056
3057     return $idx;
3058 }
3059
3060 sub elem {
3061     my $self = shift;
3062     my ($op, $cx, $left, $right, $padname) = @_;
3063     my($array, $idx) = ($op->first, $op->first->sibling);
3064
3065     $idx = $self->elem_or_slice_single_index($idx);
3066
3067     unless ($array->name eq $padname) { # Maybe this has been fixed     
3068         $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
3069     }
3070     if (my $array_name=$self->elem_or_slice_array_name
3071             ($array, $left, $padname, 1)) {
3072         return "\$" . $array_name . $left . $idx . $right;
3073     } else {
3074         # $x[20][3]{hi} or expr->[20]
3075         my $arrow = is_subscriptable($array) ? "" : "->";
3076         return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
3077     }
3078
3079 }
3080
3081 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
3082 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
3083
3084 sub pp_gelem {
3085     my $self = shift;
3086     my($op, $cx) = @_;
3087     my($glob, $part) = ($op->first, $op->last);
3088     $glob = $glob->first; # skip rv2gv
3089     $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
3090     my $scope = is_scope($glob);
3091     $glob = $self->deparse($glob, 0);
3092     $part = $self->deparse($part, 1);
3093     return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
3094 }
3095
3096 sub slice {
3097     my $self = shift;
3098     my ($op, $cx, $left, $right, $regname, $padname) = @_;
3099     my $last;
3100     my(@elems, $kid, $array, $list);
3101     if (class($op) eq "LISTOP") {
3102         $last = $op->last;
3103     } else { # ex-hslice inside delete()
3104         for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
3105         $last = $kid;
3106     }
3107     $array = $last;
3108     $array = $array->first
3109         if $array->name eq $regname or $array->name eq "null";
3110     $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
3111     $kid = $op->first->sibling; # skip pushmark
3112     if ($kid->name eq "list") {
3113         $kid = $kid->first->sibling; # skip list, pushmark
3114         for (; !null $kid; $kid = $kid->sibling) {
3115             push @elems, $self->deparse($kid, 6);
3116         }
3117         $list = join(", ", @elems);
3118     } else {
3119         $list = $self->elem_or_slice_single_index($kid);
3120     }
3121     return "\@" . $array . $left . $list . $right;
3122 }
3123
3124 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
3125 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
3126
3127 sub pp_lslice {
3128     my $self = shift;
3129     my($op, $cx) = @_;
3130     my $idx = $op->first;
3131     my $list = $op->last;
3132     my(@elems, $kid);
3133     $list = $self->deparse($list, 1);
3134     $idx = $self->deparse($idx, 1);
3135     return "($list)" . "[$idx]";
3136 }
3137
3138 sub want_scalar {
3139     my $op = shift;
3140     return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
3141 }
3142
3143 sub want_list {
3144     my $op = shift;
3145     return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
3146 }
3147
3148 sub _method {
3149     my $self = shift;
3150     my($op, $cx) = @_;
3151     my $kid = $op->first->sibling; # skip pushmark
3152     my($meth, $obj, @exprs);
3153     if ($kid->name eq "list" and want_list $kid) {
3154         # When an indirect object isn't a bareword but the args are in
3155         # parens, the parens aren't part of the method syntax (the LLAFR
3156         # doesn't apply), but they make a list with OPf_PARENS set that
3157         # doesn't get flattened by the append_elem that adds the method,
3158         # making a (object, arg1, arg2, ...) list where the object
3159         # usually is. This can be distinguished from
3160         # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
3161         # object) because in the later the list is in scalar context
3162         # as the left side of -> always is, while in the former
3163         # the list is in list context as method arguments always are.
3164         # (Good thing there aren't method prototypes!)
3165         $meth = $kid->sibling;
3166         $kid = $kid->first->sibling; # skip pushmark
3167         $obj = $kid;
3168         $kid = $kid->sibling;
3169         for (; not null $kid; $kid = $kid->sibling) {
3170             push @exprs, $kid;
3171         }
3172     } else {
3173         $obj = $kid;
3174         $kid = $kid->sibling;
3175         for (; !null ($kid->sibling) && $kid->name ne "method_named";
3176               $kid = $kid->sibling) {
3177             push @exprs, $kid
3178         }
3179         $meth = $kid;
3180     }
3181
3182     if ($meth->name eq "method_named") {
3183         $meth = $self->const_sv($meth)->PV;
3184     } else {
3185         $meth = $meth->first;
3186         if ($meth->name eq "const") {
3187             # As of 5.005_58, this case is probably obsoleted by the
3188             # method_named case above
3189             $meth = $self->const_sv($meth)->PV; # needs to be bare
3190         }
3191     }
3192
3193     return { method => $meth, variable_method => ref($meth),
3194              object => $obj, args => \@exprs  };
3195 }
3196
3197 # compat function only
3198 sub method {
3199     my $self = shift;
3200     my $info = $self->_method(@_);
3201     return $self->e_method( $self->_method(@_) );
3202 }
3203
3204 sub e_method {
3205     my ($self, $info) = @_;
3206     my $obj = $self->deparse($info->{object}, 24);
3207
3208     my $meth = $info->{method};
3209     $meth = $self->deparse($meth, 1) if $info->{variable_method};
3210     my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
3211     my $kid = $obj . "->" . $meth;
3212     if (length $args) {
3213         return $kid . "(" . $args . ")"; # parens mandatory
3214     } else {
3215         return $kid;
3216     }
3217 }
3218
3219 # returns "&" if the prototype doesn't match the args,
3220 # or ("", $args_after_prototype_demunging) if it does.
3221 sub check_proto {
3222     my $self = shift;
3223     return "&" if $self->{'noproto'};
3224     my($proto, @args) = @_;
3225     my($arg, $real);
3226     my $doneok = 0;
3227     my @reals;
3228     # An unbackslashed @ or % gobbles up the rest of the args
3229     1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
3230     while ($proto) {
3231         $proto =~ s/^(\\?[\$\@&%*]|\\\[[\$\@&%*]+\]|;)//;
3232         my $chr = $1;
3233         if ($chr eq "") {
3234             return "&" if @args;
3235         } elsif ($chr eq ";") {
3236             $doneok = 1;
3237         } elsif ($chr eq "@" or $chr eq "%") {
3238             push @reals, map($self->deparse($_, 6), @args);
3239             @args = ();
3240         } else {
3241             $arg = shift @args;
3242             last unless $arg;
3243             if ($chr eq "\$") {
3244                 if (want_scalar $arg) {
3245                     push @reals, $self->deparse($arg, 6);
3246                 } else {
3247                     return "&";
3248                 }
3249             } elsif ($chr eq "&") {
3250                 if ($arg->name =~ /^(s?refgen|undef)$/) {
3251                     push @reals, $self->deparse($arg, 6);
3252                 } else {
3253                     return "&";
3254                 }
3255             } elsif ($chr eq "*") {
3256                 if ($arg->name =~ /^s?refgen$/
3257                     and $arg->first->first->name eq "rv2gv")
3258                   {
3259                       $real = $arg->first->first; # skip refgen, null
3260                       if ($real->first->name eq "gv") {
3261                           push @reals, $self->deparse($real, 6);
3262                       } else {
3263                           push @reals, $self->deparse($real->first, 6);
3264                       }
3265                   } else {
3266                       return "&";
3267                   }
3268             } elsif (substr($chr, 0, 1) eq "\\") {
3269                 $chr =~ tr/\\[]//d;
3270                 if ($arg->name =~ /^s?refgen$/ and
3271                     !null($real = $arg->first) and
3272                     ($chr =~ /\$/ && is_scalar($real->first)
3273                      or ($chr =~ /@/
3274                          && class($real->first->sibling) ne 'NULL'
3275                          && $real->first->sibling->name
3276                          =~ /^(rv2|pad)av$/)
3277                      or ($chr =~ /%/
3278                          && class($real->first->sibling) ne 'NULL'
3279                          && $real->first->sibling->name
3280                          =~ /^(rv2|pad)hv$/)
3281                      #or ($chr =~ /&/ # This doesn't work
3282                      #   && $real->first->name eq "rv2cv")
3283                      or ($chr =~ /\*/
3284                          && $real->first->name eq "rv2gv")))
3285                   {
3286                       push @reals, $self->deparse($real, 6);
3287                   } else {
3288                       return "&";
3289                   }
3290             }
3291        }
3292     }
3293     return "&" if $proto and !$doneok; # too few args and no `;'
3294     return "&" if @args;               # too many args
3295     return ("", join ", ", @reals);
3296 }
3297
3298 sub pp_entersub {
3299     my $self = shift;
3300     my($op, $cx) = @_;
3301     return $self->e_method($self->_method($op, $cx))
3302         unless null $op->first->sibling;
3303     my $prefix = "";
3304     my $amper = "";
3305     my($kid, @exprs);
3306     if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
3307         $prefix = "do ";
3308     } elsif ($op->private & OPpENTERSUB_AMPER) {
3309         $amper = "&";
3310     }
3311     $kid = $op->first;
3312     $kid = $kid->first->sibling; # skip ex-list, pushmark
3313     for (; not null $kid->sibling; $kid = $kid->sibling) {
3314         push @exprs, $kid;
3315     }
3316     my $simple = 0;
3317     my $proto = undef;
3318     if (is_scope($kid)) {
3319         $amper = "&";
3320         $kid = "{" . $self->deparse($kid, 0) . "}";
3321     } elsif ($kid->first->name eq "gv") {
3322         my $gv = $self->gv_or_padgv($kid->first);
3323         if (class($gv->CV) ne "SPECIAL") {
3324             $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
3325         }
3326         $simple = 1; # only calls of named functions can be prototyped
3327         $kid = $self->deparse($kid, 24);
3328         if (!$amper) {
3329             if ($kid eq 'main::') {
3330                 $kid = '::';
3331             } elsif ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
3332                 $kid = single_delim("q", "'", $kid) . '->';
3333             }
3334         }
3335     } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
3336         $amper = "&";
3337         $kid = $self->deparse($kid, 24);
3338     } else {
3339         $prefix = "";
3340         my $arrow = is_subscriptable($kid->first) ? "" : "->";
3341         $kid = $self->deparse($kid, 24) . $arrow;
3342     }
3343
3344     # Doesn't matter how many prototypes there are, if
3345     # they haven't happened yet!
3346     my $declared;
3347     {
3348         no strict 'refs';
3349         no warnings 'uninitialized';
3350         $declared = exists $self->{'subs_declared'}{$kid}
3351             || (
3352                  defined &{ ${$self->{'curstash'}."::"}{$kid} }
3353                  && !exists
3354                      $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
3355                  && defined prototype $self->{'curstash'}."::".$kid
3356                );
3357         if (!$declared && defined($proto)) {
3358             # Avoid "too early to check prototype" warning
3359             ($amper, $proto) = ('&');
3360         }
3361     }
3362
3363     my $args;
3364     if ($declared and defined $proto and not $amper) {
3365         ($amper, $args) = $self->check_proto($proto, @exprs);
3366         if ($amper eq "&") {
3367             $args = join(", ", map($self->deparse($_, 6), @exprs));
3368         }
3369     } else {
3370         $args = join(", ", map($self->deparse($_, 6), @exprs));
3371     }
3372     if ($prefix or $amper) {
3373         if ($op->flags & OPf_STACKED) {
3374             return $prefix . $amper . $kid . "(" . $args . ")";
3375         } else {
3376             return $prefix . $amper. $kid;
3377         }
3378     } else {
3379         # glob() invocations can be translated into calls of
3380         # CORE::GLOBAL::glob with a second parameter, a number.
3381         # Reverse this.
3382         if ($kid eq "CORE::GLOBAL::glob") {
3383             $kid = "glob";
3384             $args =~ s/\s*,[^,]+$//;
3385         }
3386
3387         # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
3388         # so it must have been translated from a keyword call. Translate
3389         # it back.
3390         $kid =~ s/^CORE::GLOBAL:://;
3391
3392         my $dproto = defined($proto) ? $proto : "undefined";
3393         if (!$declared) {
3394             return "$kid(" . $args . ")";
3395         } elsif ($dproto eq "") {
3396             return $kid;
3397         } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
3398             # is_scalar is an excessively conservative test here:
3399             # really, we should be comparing to the precedence of the
3400             # top operator of $exprs[0] (ala unop()), but that would
3401             # take some major code restructuring to do right.
3402             return $self->maybe_parens_func($kid, $args, $cx, 16);
3403         } elsif ($dproto ne '$' and defined($proto) || $simple) { #'
3404             return $self->maybe_parens_func($kid, $args, $cx, 5);
3405         } else {
3406             return "$kid(" . $args . ")";
3407         }
3408     }
3409 }
3410
3411 sub pp_enterwrite { unop(@_, "write") }
3412
3413 # escape things that cause interpolation in double quotes,
3414 # but not character escapes
3415 sub uninterp {
3416     my($str) = @_;
3417     $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
3418     return $str;
3419 }
3420
3421 {
3422 my $bal;
3423 BEGIN {
3424     use re "eval";
3425     # Matches any string which is balanced with respect to {braces}
3426     $bal = qr(
3427       (?:
3428         [^\\{}]
3429       | \\\\
3430       | \\[{}]
3431       | \{(??{$bal})\}
3432       )*
3433     )x;
3434 }
3435
3436 # the same, but treat $|, $), $( and $ at the end of the string differently
3437 sub re_uninterp {
3438     my($str) = @_;
3439
3440     $str =~ s/
3441           ( ^|\G                  # $1
3442           | [^\\]
3443           )
3444
3445           (                       # $2
3446             (?:\\\\)*
3447           )
3448
3449           (                       # $3
3450             (\(\?\??\{$bal\}\))   # $4
3451           | [\$\@]
3452             (?!\||\)|\(|$)
3453           | \\[uUlLQE]
3454           )
3455
3456         /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3457
3458     return $str;
3459 }
3460
3461 # This is for regular expressions with the /x modifier
3462 # We have to leave comments unmangled.
3463 sub re_uninterp_extended {
3464     my($str) = @_;
3465
3466     $str =~ s/
3467           ( ^|\G                  # $1
3468           | [^\\]
3469           )
3470
3471           (                       # $2
3472             (?:\\\\)*
3473           )
3474
3475           (                       # $3
3476             ( \(\?\??\{$bal\}\)   # $4  (skip over (?{}) and (??{}) blocks)
3477             | \#[^\n]*            #     (skip over comments)
3478             )
3479           | [\$\@]
3480             (?!\||\)|\(|$|\s)
3481           | \\[uUlLQE]
3482           )
3483
3484         /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3485
3486     return $str;
3487 }
3488 }
3489
3490 my %unctrl = # portable to to EBCDIC
3491     (
3492      "\c@" => '\c@',    # unused
3493      "\cA" => '\cA',
3494      "\cB" => '\cB',
3495      "\cC" => '\cC',
3496      "\cD" => '\cD',
3497      "\cE" => '\cE',
3498      "\cF" => '\cF',
3499      "\cG" => '\cG',
3500      "\cH" => '\cH',
3501      "\cI" => '\cI',
3502      "\cJ" => '\cJ',
3503      "\cK" => '\cK',
3504      "\cL" => '\cL',
3505      "\cM" => '\cM',
3506      "\cN" => '\cN',
3507      "\cO" => '\cO',
3508      "\cP" => '\cP',
3509      "\cQ" => '\cQ',
3510      "\cR" => '\cR',
3511      "\cS" => '\cS',
3512      "\cT" => '\cT',
3513      "\cU" => '\cU',
3514      "\cV" => '\cV',
3515      "\cW" => '\cW',
3516      "\cX" => '\cX',
3517      "\cY" => '\cY',
3518      "\cZ" => '\cZ',
3519      "\c[" => '\c[',    # unused
3520      "\c\\" => '\c\\',  # unused
3521      "\c]" => '\c]',    # unused
3522      "\c_" => '\c_',    # unused
3523     );
3524
3525 # character escapes, but not delimiters that might need to be escaped
3526 sub escape_str { # ASCII, UTF8
3527     my($str) = @_;
3528     $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3529     $str =~ s/\a/\\a/g;
3530 #    $str =~ s/\cH/\\b/g; # \b means something different in a regex
3531     $str =~ s/\t/\\t/g;
3532     $str =~ s/\n/\\n/g;
3533     $str =~ s/\e/\\e/g;
3534     $str =~ s/\f/\\f/g;
3535     $str =~ s/\r/\\r/g;
3536     $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
3537     $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
3538     return $str;
3539 }
3540
3541 # For regexes with the /x modifier.
3542 # Leave whitespace unmangled.
3543 sub escape_extended_re {
3544     my($str) = @_;
3545     $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3546     $str =~ s/([[:^print:]])/
3547         ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
3548     $str =~ s/\n/\n\f/g;
3549     return $str;
3550 }
3551
3552 # Don't do this for regexen
3553 sub unback {
3554     my($str) = @_;
3555     $str =~ s/\\/\\\\/g;
3556     return $str;
3557 }
3558
3559 # Remove backslashes which precede literal control characters,
3560 # to avoid creating ambiguity when we escape the latter.
3561 sub re_unback {
3562     my($str) = @_;
3563
3564     # the insane complexity here is due to the behaviour of "\c\"
3565     $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
3566     return $str;
3567 }
3568
3569 sub balanced_delim {
3570     my($str) = @_;
3571     my @str = split //, $str;
3572     my($ar, $open, $close, $fail, $c, $cnt, $last_bs);
3573     for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
3574         ($open, $close) = @$ar;
3575         $fail = 0; $cnt = 0; $last_bs = 0;
3576         for $c (@str) {
3577             if ($c eq $open) {
3578                 $fail = 1 if $last_bs;
3579                 $cnt++;
3580             } elsif ($c eq $close) {
3581                 $fail = 1 if $last_bs;
3582                 $cnt--;
3583                 if ($cnt < 0) {
3584                     # qq()() isn't ")("
3585                     $fail = 1;
3586                     last;
3587                 }
3588             }
3589             $last_bs = $c eq '\\';
3590         }
3591         $fail = 1 if $cnt != 0;
3592         return ($open, "$open$str$close") if not $fail;
3593     }
3594     return ("", $str);
3595 }
3596
3597 sub single_delim {
3598     my($q, $default, $str) = @_;
3599     return "$default$str$default" if $default and index($str, $default) == -1;
3600     if ($q ne 'qr') {
3601         (my $succeed, $str) = balanced_delim($str);
3602         return "$q$str" if $succeed;
3603     }
3604     for my $delim ('/', '"', '#') {
3605         return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3606     }
3607     if ($default) {
3608         $str =~ s/$default/\\$default/g;
3609         return "$default$str$default";
3610     } else {
3611         $str =~ s[/][\\/]g;
3612         return "$q/$str/";
3613     }
3614 }
3615
3616 my $max_prec;
3617 BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
3618
3619 # Split a floating point number into an integer mantissa and a binary
3620 # exponent. Assumes you've already made sure the number isn't zero or
3621 # some weird infinity or NaN.
3622 sub split_float {
3623     my($f) = @_;
3624     my $exponent = 0;
3625     if ($f == int($f)) {
3626         while ($f % 2 == 0) {
3627             $f /= 2;
3628             $exponent++;
3629         }
3630     } else {
3631         while ($f != int($f)) {
3632             $f *= 2;
3633             $exponent--;
3634         }
3635     }
3636     my $mantissa = sprintf("%.0f", $f);
3637     return ($mantissa, $exponent);
3638 }
3639
3640 sub const {
3641     my $self = shift;
3642     my($sv, $cx) = @_;
3643     if ($self->{'use_dumper'}) {
3644         return $self->const_dumper($sv, $cx);
3645     }
3646     if (class($sv) eq "SPECIAL") {
3647         # sv_undef, sv_yes, sv_no
3648         return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1];
3649     } elsif (class($sv) eq "NULL") {
3650        return 'undef';
3651     } elsif (my $const = $self->{'inlined_constants'}->{ 0 + $sv->object_2svref }) {
3652         return $const;
3653     }
3654     # convert a version object into the "v1.2.3" string in its V magic
3655     if ($sv->FLAGS & SVs_RMG) {
3656         for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
3657             return $mg->PTR if $mg->TYPE eq 'V';
3658         }
3659     }
3660
3661     if ($sv->FLAGS & SVf_IOK) {
3662         my $str = $sv->int_value;
3663         $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
3664         return $str;
3665     } elsif ($sv->FLAGS & SVf_NOK) {
3666         my $nv = $sv->NV;
3667         if ($nv == 0) {
3668             if (pack("F", $nv) eq pack("F", 0)) {
3669                 # positive zero
3670                 return "0";
3671             } else {
3672                 # negative zero
3673                 return $self->maybe_parens("-.0", $cx, 21);
3674             }
3675         } elsif (1/$nv == 0) {
3676             if ($nv > 0) {
3677                 # positive infinity
3678                 return $self->maybe_parens("9**9**9", $cx, 22);
3679             } else {
3680                 # negative infinity
3681                 return $self->maybe_parens("-9**9**9", $cx, 21);
3682             }
3683         } elsif ($nv != $nv) {
3684             # NaN
3685             if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
3686                 # the normal kind
3687                 return "sin(9**9**9)";
3688             } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
3689                 # the inverted kind
3690                 return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
3691             } else {
3692                 # some other kind
3693                 my $hex = unpack("h*", pack("F", $nv));
3694                 return qq'unpack("F", pack("h*", "$hex"))';
3695             }
3696         }
3697         # first, try the default stringification
3698         my $str = "$nv";
3699         if ($str != $nv) {
3700             # failing that, try using more precision
3701             $str = sprintf("%.${max_prec}g", $nv);
3702 #           if (pack("F", $str) ne pack("F", $nv)) {
3703             if ($str != $nv) {
3704                 # not representable in decimal with whatever sprintf()
3705                 # and atof() Perl is using here.
3706                 my($mant, $exp) = split_float($nv);
3707                 return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
3708             }
3709         }
3710         $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
3711         return $str;
3712     } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3713         my $ref = $sv->RV;
3714         if (class($ref) eq "AV") {
3715             return "[" . $self->list_const(2, $ref->ARRAY) . "]";
3716         } elsif (class($ref) eq "HV") {
3717             my %hash = $ref->ARRAY;
3718             my @elts;
3719             for my $k (sort keys %hash) {
3720                 push @elts, "$k => " . $self->const($hash{$k}, 6);
3721             }
3722             return "{" . join(", ", @elts) . "}";
3723         } elsif (class($ref) eq "CV") {
3724             return "sub " . $self->deparse_sub($ref);
3725         }
3726         if ($ref->FLAGS & SVs_SMG) {
3727             for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
3728                 if ($mg->TYPE eq 'r') {
3729                     my $re = re_uninterp(escape_str(re_unback($mg->precomp)));
3730                     return single_delim("qr", "", $re);
3731                 }
3732             }
3733         }
3734         
3735         return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20);
3736     } elsif ($sv->FLAGS & SVf_POK) {
3737         my $str = $sv->PV;
3738         if ($str =~ /[[:^print:]]/) {
3739             return single_delim("qq", '"', uninterp escape_str unback $str);
3740         } else {
3741             return single_delim("q", "'", unback $str);
3742         }
3743     } else {
3744         return "undef";
3745     }
3746 }
3747
3748 sub const_dumper {
3749     my $self = shift;
3750     my($sv, $cx) = @_;
3751     my $ref = $sv->object_2svref();
3752     my $dumper = Data::Dumper->new([$$ref], ['$v']);
3753     $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
3754     my $str = $dumper->Dump();
3755     if ($str =~ /^\$v/) {
3756         return '${my ' . $str . ' \$v}';
3757     } else {
3758         return $str;
3759     }
3760 }
3761
3762 sub const_sv {
3763     my $self = shift;
3764     my $op = shift;
3765     my $sv = $op->sv;
3766     # the constant could be in the pad (under useithreads)
3767     $sv = $self->padval($op->targ) unless $$sv;
3768     return $sv;
3769 }
3770
3771 sub pp_const {
3772     my $self = shift;
3773     my($op, $cx) = @_;
3774     if ($op->private & OPpCONST_ARYBASE) {
3775         return '$[';
3776     }
3777 #    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3778 #       return $self->const_sv($op)->PV;
3779 #    }
3780     my $sv = $self->const_sv($op);
3781     return $self->const($sv, $cx);
3782 }
3783
3784 sub dq {
3785     my $self = shift;
3786     my $op = shift;
3787     my $type = $op->name;
3788     if ($type eq "const") {
3789         return '$[' if $op->private & OPpCONST_ARYBASE;
3790         return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3791     } elsif ($type eq "concat") {
3792         my $first = $self->dq($op->first);
3793         my $last  = $self->dq($op->last);
3794
3795         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
3796         ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3797             $first =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
3798             || ($last =~ /^[:'{\[\w_]/ && #'
3799                 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3800
3801         return $first . $last;
3802     } elsif ($type eq "uc") {
3803         return '\U' . $self->dq($op->first->sibling) . '\E';
3804     } elsif ($type eq "lc") {
3805         return '\L' . $self->dq($op->first->sibling) . '\E';
3806     } elsif ($type eq "ucfirst") {
3807         return '\u' . $self->dq($op->first->sibling);
3808     } elsif ($type eq "lcfirst") {
3809         return '\l' . $self->dq($op->first->sibling);
3810     } elsif ($type eq "quotemeta") {
3811         return '\Q' . $self->dq($op->first->sibling) . '\E';
3812     } elsif ($type eq "join") {
3813         return $self->deparse($op->last, 26); # was join($", @ary)
3814     } else {
3815         return $self->deparse($op, 26);
3816     }
3817 }
3818
3819 sub pp_backtick {
3820     my $self = shift;
3821     my($op, $cx) = @_;
3822     # skip pushmark if it exists (readpipe() vs ``)
3823     my $child = $op->first->sibling->isa('B::NULL')
3824         ? $op->first->first : $op->first->sibling;
3825     return single_delim("qx", '`', $self->dq($child));
3826 }
3827
3828 sub dquote {
3829     my $self = shift;
3830     my($op, $cx) = @_;
3831     my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3832     return $self->deparse($kid, $cx) if $self->{'unquote'};
3833     $self->maybe_targmy($kid, $cx,
3834                         sub {single_delim("qq", '"', $self->dq($_[1]))});
3835 }
3836
3837 # OP_STRINGIFY is a listop, but it only ever has one arg
3838 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3839
3840 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3841 # note that tr(from)/to/ is OK, but not tr/from/(to)
3842 sub double_delim {
3843     my($from, $to) = @_;
3844     my($succeed, $delim);
3845     if ($from !~ m[/] and $to !~ m[/]) {
3846         return "/$from/$to/";
3847     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3848         if (($succeed, $to) = balanced_delim($to) and $succeed) {
3849             return "$from$to";
3850         } else {
3851             for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3852                 return "$from$delim$to$delim" if index($to, $delim) == -1;
3853             }
3854             $to =~ s[/][\\/]g;
3855             return "$from/$to/";
3856         }
3857     } else {
3858         for $delim ('/', '"', '#') { # note no '
3859             return "$delim$from$delim$to$delim"
3860                 if index($to . $from, $delim) == -1;
3861         }
3862         $from =~ s[/][\\/]g;
3863         $to =~ s[/][\\/]g;
3864         return "/$from/$to/";   
3865     }
3866 }
3867
3868 # Only used by tr///, so backslashes hyphens
3869 sub pchr { # ASCII
3870     my($n) = @_;
3871     if ($n == ord '\\') {
3872         return '\\\\';
3873     } elsif ($n == ord "-") {
3874         return "\\-";
3875     } elsif ($n >= ord(' ') and $n <= ord('~')) {
3876         return chr($n);
3877     } elsif ($n == ord "\a") {
3878         return '\\a';
3879     } elsif ($n == ord "\b") {
3880         return '\\b';
3881     } elsif ($n == ord "\t") {
3882         return '\\t';
3883     } elsif ($n == ord "\n") {
3884         return '\\n';
3885     } elsif ($n == ord "\e") {
3886         return '\\e';
3887     } elsif ($n == ord "\f") {
3888         return '\\f';
3889     } elsif ($n == ord "\r") {
3890         return '\\r';
3891     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3892         return '\\c' . chr(ord("@") + $n);
3893     } else {
3894 #       return '\x' . sprintf("%02x", $n);
3895         return '\\' . sprintf("%03o", $n);
3896     }
3897 }
3898
3899 sub collapse {
3900     my(@chars) = @_;
3901     my($str, $c, $tr) = ("");
3902     for ($c = 0; $c < @chars; $c++) {
3903         $tr = $chars[$c];
3904         $str .= pchr($tr);
3905         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3906             $chars[$c + 2] == $tr + 2)
3907         {
3908             for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3909               {}
3910             $str .= "-";
3911             $str .= pchr($chars[$c]);
3912         }
3913     }
3914     return $str;
3915 }
3916
3917 sub tr_decode_byte {
3918     my($table, $flags) = @_;
3919     my(@table) = unpack("s*", $table);
3920     splice @table, 0x100, 1;   # Number of subsequent elements
3921     my($c, $tr, @from, @to, @delfrom, $delhyphen);
3922     if ($table[ord "-"] != -1 and
3923         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3924     {
3925         $tr = $table[ord "-"];
3926         $table[ord "-"] = -1;
3927         if ($tr >= 0) {
3928             @from = ord("-");
3929             @to = $tr;
3930         } else { # -2 ==> delete
3931             $delhyphen = 1;
3932         }
3933     }
3934     for ($c = 0; $c < @table; $c++) {
3935         $tr = $table[$c];
3936         if ($tr >= 0) {
3937             push @from, $c; push @to, $tr;
3938         } elsif ($tr == -2) {
3939             push @delfrom, $c;
3940         }
3941     }
3942     @from = (@from, @delfrom);
3943     if ($flags & OPpTRANS_COMPLEMENT) {
3944         my @newfrom = ();
3945         my %from;
3946         @from{@from} = (1) x @from;
3947         for ($c = 0; $c < 256; $c++) {
3948             push @newfrom, $c unless $from{$c};
3949         }
3950         @from = @newfrom;
3951     }
3952     unless ($flags & OPpTRANS_DELETE || !@to) {
3953         pop @to while $#to and $to[$#to] == $to[$#to -1];
3954     }
3955     my($from, $to);
3956     $from = collapse(@from);
3957     $to = collapse(@to);
3958     $from .= "-" if $delhyphen;
3959     return ($from, $to);
3960 }
3961
3962 sub tr_chr {
3963     my $x = shift;
3964     if ($x == ord "-") {
3965         return "\\-";
3966     } elsif ($x == ord "\\") {
3967         return "\\\\";
3968     } else {
3969         return chr $x;
3970     }
3971 }
3972
3973 # XXX This doesn't yet handle all cases correctly either
3974
3975 sub tr_decode_utf8 {
3976     my($swash_hv, $flags) = @_;
3977     my %swash = $swash_hv->ARRAY;
3978     my $final = undef;
3979     $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3980     my $none = $swash{"NONE"}->IV;
3981     my $extra = $none + 1;
3982     my(@from, @delfrom, @to);
3983     my $line;
3984     foreach $line (split /\n/, $swash{'LIST'}->PV) {
3985         my($min, $max, $result) = split(/\t/, $line);
3986         $min = hex $min;
3987         if (length $max) {
3988             $max = hex $max;
3989         } else {
3990             $max = $min;
3991         }
3992         $result = hex $result;
3993         if ($result == $extra) {
3994             push @delfrom, [$min, $max];
3995         } else {
3996             push @from, [$min, $max];
3997             push @to, [$result, $result + $max - $min];
3998         }
3999     }
4000     for my $i (0 .. $#from) {
4001         if ($from[$i][0] == ord '-') {
4002             unshift @from, splice(@from, $i, 1);
4003             unshift @to, splice(@to, $i, 1);
4004             last;
4005         } elsif ($from[$i][1] == ord '-') {
4006             $from[$i][1]--;
4007             $to[$i][1]--;
4008             unshift @from, ord '-';
4009             unshift @to, ord '-';
4010             last;
4011         }
4012     }
4013     for my $i (0 .. $#delfrom) {
4014         if ($delfrom[$i][0] == ord '-') {
4015             push @delfrom, splice(@delfrom, $i, 1);
4016             last;
4017         } elsif ($delfrom[$i][1] == ord '-') {
4018             $delfrom[$i][1]--;
4019             push @delfrom, ord '-';
4020             last;
4021         }
4022     }
4023     if (defined $final and $to[$#to][1] != $final) {
4024         push @to, [$final, $final];
4025     }
4026     push @from, @delfrom;
4027     if ($flags & OPpTRANS_COMPLEMENT) {
4028         my @newfrom;
4029         my $next = 0;
4030         for my $i (0 .. $#from) {
4031             push @newfrom, [$next, $from[$i][0] - 1];
4032             $next = $from[$i][1] + 1;
4033         }
4034         @from = ();
4035         for my $range (@newfrom) {
4036             if ($range->[0] <= $range->[1]) {
4037                 push @from, $range;
4038             }
4039         }
4040     }
4041     my($from, $to, $diff);
4042     for my $chunk (@from) {
4043         $diff = $chunk->[1] - $chunk->[0];
4044         if ($diff > 1) {
4045             $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
4046         } elsif ($diff == 1) {
4047             $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
4048         } else {
4049             $from .= tr_chr($chunk->[0]);
4050         }
4051     }
4052     for my $chunk (@to) {
4053         $diff = $chunk->[1] - $chunk->[0];
4054         if ($diff > 1) {
4055             $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
4056         } elsif ($diff == 1) {
4057             $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
4058         } else {
4059             $to .= tr_chr($chunk->[0]);
4060         }
4061     }
4062     #$final = sprintf("%04x", $final) if defined $final;
4063     #$none = sprintf("%04x", $none) if defined $none;
4064     #$extra = sprintf("%04x", $extra) if defined $extra;
4065     #print STDERR "final: $final\n none: $none\nextra: $extra\n";
4066     #print STDERR $swash{'LIST'}->PV;
4067     return (escape_str($from), escape_str($to));
4068 }
4069
4070 sub pp_trans {
4071     my $self = shift;
4072     my($op, $cx) = @_;
4073     my($from, $to);
4074     if (class($op) eq "PVOP") {
4075         ($from, $to) = tr_decode_byte($op->pv, $op->private);
4076     } else { # class($op) eq "SVOP"
4077         ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
4078     }
4079     my $flags = "";
4080     $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
4081     $flags .= "d" if $op->private & OPpTRANS_DELETE;
4082     $to = "" if $from eq $to and $flags eq "";
4083     $flags .= "s" if $op->private & OPpTRANS_SQUASH;
4084     return "tr" . double_delim($from, $to) . $flags;
4085 }
4086
4087 sub re_dq_disambiguate {
4088     my ($first, $last) = @_;
4089     # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
4090     ($last =~ /^[A-Z\\\^\[\]_?]/ &&
4091         $first =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
4092         || ($last =~ /^[{\[\w_]/ &&
4093             $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
4094     return $first . $last;
4095 }
4096
4097 # Like dq(), but different
4098 sub re_dq {
4099     my $self = shift;
4100     my ($op, $extended) = @_;
4101
4102     my $type = $op->name;
4103     if ($type eq "const") {
4104         return '$[' if $op->private & OPpCONST_ARYBASE;
4105         my $unbacked = re_unback($self->const_sv($op)->as_string);
4106         return re_uninterp_extended(escape_extended_re($unbacked))
4107             if $extended;
4108         return re_uninterp(escape_str($unbacked));
4109     } elsif ($type eq "concat") {
4110         my $first = $self->re_dq($op->first, $extended);
4111         my $last  = $self->re_dq($op->last,  $extended);
4112         return re_dq_disambiguate($first, $last);
4113     } elsif ($type eq "uc") {
4114         return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
4115     } elsif ($type eq "lc") {
4116         return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
4117     } elsif ($type eq "ucfirst") {
4118         return '\u' . $self->re_dq($op->first->sibling, $extended);
4119     } elsif ($type eq "lcfirst") {
4120         return '\l' . $self->re_dq($op->first->sibling, $extended);
4121     } elsif ($type eq "quotemeta") {
4122         return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
4123     } elsif ($type eq "join") {
4124         return $self->deparse($op->last, 26); # was join($", @ary)
4125     } else {
4126         return $self->deparse($op, 26);
4127     }
4128 }
4129
4130 sub pure_string {
4131     my ($self, $op) = @_;
4132     return 0 if null $op;
4133     my $type = $op->name;
4134
4135     if ($type eq 'const') {
4136         return 1;
4137     }
4138     elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
4139         return $self->pure_string($op->first->sibling);
4140     }
4141     elsif ($type eq 'join') {
4142         my $join_op = $op->first->sibling;  # Skip pushmark
4143         return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
4144
4145         my $gvop = $join_op->first;
4146         return 0 unless $gvop->name eq 'gvsv';
4147         return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
4148
4149         return 0 unless ${$join_op->sibling} eq ${$op->last};
4150         return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
4151     }
4152     elsif ($type eq 'concat') {
4153         return $self->pure_string($op->first)
4154             && $self->pure_string($op->last);
4155     }
4156     elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
4157         return 1;
4158     }
4159     elsif ($type eq "null" and $op->can('first') and not null $op->first and
4160            $op->first->name eq "null" and $op->first->can('first')
4161            and not null $op->first->first and
4162            $op->first->first->name eq "aelemfast") {
4163         return 1;
4164     }
4165     else {
4166         return 0;
4167     }
4168
4169     return 1;
4170 }
4171
4172 sub regcomp {
4173     my $self = shift;
4174     my($op, $cx, $extended) = @_;
4175     my $kid = $op->first;
4176     $kid = $kid->first if $kid->name eq "regcmaybe";
4177     $kid = $kid->first if $kid->name eq "regcreset";
4178     if ($kid->name eq "null" and !null($kid->first)
4179         and $kid->first->name eq 'pushmark')
4180     {
4181         my $str = '';
4182         $kid = $kid->first->sibling;
4183         while (!null($kid)) {
4184             my $first = $str;
4185             my $last = $self->re_dq($kid, $extended);
4186             $str = re_dq_disambiguate($first, $last);
4187             $kid = $kid->sibling;
4188         }
4189         return $str, 1;
4190     }
4191
4192     return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
4193     return ($self->deparse($kid, $cx), 0);
4194 }
4195
4196 sub pp_regcomp {
4197     my ($self, $op, $cx) = @_;
4198     return (($self->regcomp($op, $cx, 0))[0]);
4199 }
4200
4201 # osmic acid -- see osmium tetroxide
4202
4203 my %matchwords;
4204 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
4205     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
4206     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
4207
4208 sub matchop {
4209     my $self = shift;
4210     my($op, $cx, $name, $delim) = @_;
4211     my $kid = $op->first;
4212     my ($binop, $var, $re) = ("", "", "");
4213     if ($op->flags & OPf_STACKED) {
4214         $binop = 1;
4215         $var = $self->deparse($kid, 20);
4216         $kid = $kid->sibling;
4217     }
4218     my $quote = 1;
4219     my $extended = ($op->pmflags & PMf_EXTENDED);
4220     if (null $kid) {
4221         my $unbacked = re_unback($op->precomp);
4222         if ($extended) {
4223             $re = re_uninterp_extended(escape_extended_re($unbacked));
4224         } else {
4225             $re = re_uninterp(escape_str(re_unback($op->precomp)));
4226         }
4227     } elsif ($kid->name ne 'regcomp') {
4228         carp("found ".$kid->name." where regcomp expected");
4229     } else {
4230         ($re, $quote) = $self->regcomp($kid, 21, $extended);
4231     }
4232     my $flags = "";
4233     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
4234     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
4235     $flags .= "i" if $op->pmflags & PMf_FOLD;
4236     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
4237     $flags .= "o" if $op->pmflags & PMf_KEEP;
4238     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
4239     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
4240     $flags = $matchwords{$flags} if $matchwords{$flags};
4241     if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
4242         $re =~ s/\?/\\?/g;
4243         $re = "?$re?";
4244     } elsif ($quote) {
4245         $re = single_delim($name, $delim, $re);
4246     }
4247     $re = $re . $flags if $quote;
4248     if ($binop) {
4249         return $self->maybe_parens("$var =~ $re", $cx, 20);
4250     } else {
4251         return $re;
4252     }
4253 }
4254
4255 sub pp_match { matchop(@_, "m", "/") }
4256 sub pp_pushre { matchop(@_, "m", "/") }
4257 sub pp_qr { matchop(@_, "qr", "") }
4258
4259 sub pp_split {
4260     my $self = shift;
4261     my($op, $cx) = @_;
4262     my($kid, @exprs, $ary, $expr);
4263     $kid = $op->first;
4264
4265     # For our kid (an OP_PUSHRE), pmreplroot is never actually the
4266     # root of a replacement; it's either empty, or abused to point to
4267     # the GV for an array we split into (an optimization to save
4268     # assignment overhead). Depending on whether we're using ithreads,
4269     # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
4270     # figures out for us which it is.
4271     my $replroot = $kid->pmreplroot;
4272     my $gv = 0;
4273     if (ref($replroot) eq "B::GV") {
4274         $gv = $replroot;
4275     } elsif (!ref($replroot) and $replroot > 0) {
4276         $gv = $self->padval($replroot);
4277     }
4278     $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv;
4279
4280     for (; !null($kid); $kid = $kid->sibling) {
4281         push @exprs, $self->deparse($kid, 6);
4282     }
4283
4284     # handle special case of split(), and split(' ') that compiles to /\s+/
4285     $kid = $op->first;
4286     if ( $kid->flags & OPf_SPECIAL
4287          and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
4288               : $kid->reflags & RXf_SKIPWHITE() ) ) {
4289         $exprs[0] = "' '";
4290     }
4291
4292     $expr = "split(" . join(", ", @exprs) . ")";
4293     if ($ary) {
4294         return $self->maybe_parens("$ary = $expr", $cx, 7);
4295     } else {
4296         return $expr;
4297     }
4298 }
4299
4300 # oxime -- any of various compounds obtained chiefly by the action of
4301 # hydroxylamine on aldehydes and ketones and characterized by the
4302 # bivalent grouping C=NOH [Webster's Tenth]
4303
4304 my %substwords;
4305 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
4306     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
4307     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
4308     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
4309
4310 sub pp_subst {
4311     my $self = shift;
4312     my($op, $cx) = @_;
4313     my $kid = $op->first;
4314     my($binop, $var, $re, $repl) = ("", "", "", "");
4315     if ($op->flags & OPf_STACKED) {
4316         $binop = 1;
4317         $var = $self->deparse($kid, 20);
4318         $kid = $kid->sibling;
4319     }
4320     my $flags = "";
4321     if (null($op->pmreplroot)) {
4322         $repl = $self->dq($kid);
4323         $kid = $kid->sibling;
4324     } else {
4325         $repl = $op->pmreplroot->first; # skip substcont
4326         while ($repl->name eq "entereval") {
4327             $repl = $repl->first;
4328             $flags .= "e";
4329         }
4330         if ($op->pmflags & PMf_EVAL) {
4331             $repl = $self->deparse($repl->first, 0);
4332         } else {
4333             $repl = $self->dq($repl);   
4334         }
4335     }
4336     my $extended = ($op->pmflags & PMf_EXTENDED);
4337     if (null $kid) {
4338         my $unbacked = re_unback($op->precomp);
4339         if ($extended) {
4340             $re = re_uninterp_extended(escape_extended_re($unbacked));
4341         }
4342         else {
4343             $re = re_uninterp(escape_str($unbacked));
4344         }
4345     } else {
4346         ($re) = $self->regcomp($kid, 1, $extended);
4347     }
4348     $flags .= "e" if $op->pmflags & PMf_EVAL;
4349     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
4350     $flags .= "i" if $op->pmflags & PMf_FOLD;
4351     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
4352     $flags .= "o" if $op->pmflags & PMf_KEEP;
4353     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
4354     $flags .= "x" if $extended;
4355     $flags = $substwords{$flags} if $substwords{$flags};
4356     if ($binop) {
4357         return $self->maybe_parens("$var =~ s"
4358                                    . double_delim($re, $repl) . $flags,
4359                                    $cx, 20);
4360     } else {
4361         return "s". double_delim($re, $repl) . $flags;  
4362     }
4363 }
4364
4365 1;
4366 __END__
4367
4368 =head1 NAME
4369
4370 B::Deparse - Perl compiler backend to produce perl code
4371
4372 =head1 SYNOPSIS
4373
4374 B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
4375         [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
4376
4377 =head1 DESCRIPTION
4378
4379 B::Deparse is a backend module for the Perl compiler that generates
4380 perl source code, based on the internal compiled structure that perl
4381 itself creates after parsing a program. The output of B::Deparse won't
4382 be exactly the same as the original source, since perl doesn't keep
4383 track of comments or whitespace, and there isn't a one-to-one
4384 correspondence between perl's syntactical constructions and their
4385 compiled form, but it will often be close. When you use the B<-p>
4386 option, the output also includes parentheses even when they are not
4387 required by precedence, which can make it easy to see if perl is
4388 parsing your expressions the way you intended.
4389
4390 While B::Deparse goes to some lengths to try to figure out what your
4391 original program was doing, some parts of the language can still trip
4392 it up; it still fails even on some parts of Perl's own test suite. If
4393 you encounter a failure other than the most common ones described in
4394 the BUGS section below, you can help contribute to B::Deparse's
4395 ongoing development by submitting a bug report with a small
4396 example.
4397
4398 =head1 OPTIONS
4399
4400 As with all compiler backend options, these must follow directly after
4401 the '-MO=Deparse', separated by a comma but not any white space.
4402
4403 =over 4
4404
4405 =item B<-d>
4406
4407 Output data values (when they appear as constants) using Data::Dumper.
4408 Without this option, B::Deparse will use some simple routines of its
4409 own for the same purpose. Currently, Data::Dumper is better for some
4410 kinds of data (such as complex structures with sharing and
4411 self-reference) while the built-in routines are better for others
4412 (such as odd floating-point values).
4413
4414 =item B<-f>I<FILE>
4415
4416 Normally, B::Deparse deparses the main code of a program, and all the subs
4417 defined in the same file. To include subs defined in other files, pass the
4418 B<-f> option with the filename. You can pass the B<-f> option several times, to
4419 include more than one secondary file.  (Most of the time you don't want to
4420 use it at all.)  You can also use this option to include subs which are
4421 defined in the scope of a B<#line> directive with two parameters.
4422
4423 =item B<-l>
4424
4425 Add '#line' declarations to the output based on the line and file
4426 locations of the original code.
4427
4428 =item B<-p>
4429
4430 Print extra parentheses. Without this option, B::Deparse includes
4431 parentheses in its output only when they are needed, based on the
4432 structure of your program. With B<-p>, it uses parentheses (almost)
4433 whenever they would be legal. This can be useful if you are used to
4434 LISP, or if you want to see how perl parses your input. If you say
4435
4436     if ($var & 0x7f == 65) {print "Gimme an A!"}
4437     print ($which ? $a : $b), "\n";
4438     $name = $ENV{USER} or "Bob";
4439
4440 C<B::Deparse,-p> will print
4441
4442     if (($var & 0)) {
4443         print('Gimme an A!')
4444     };
4445     (print(($which ? $a : $b)), '???');
4446     (($name = $ENV{'USER'}) or '???')
4447
4448 which probably isn't what you intended (the C<'???'> is a sign that
4449 perl optimized away a constant value).
4450
4451 =item B<-P>
4452
4453 Disable prototype checking. With this option, all function calls are
4454 deparsed as if no prototype was defined for them. In other words,
4455
4456     perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
4457
4458 will print
4459
4460     sub foo (\@) {
4461         1;
4462     }
4463     &foo(\@x);
4464
4465 making clear how the parameters are actually passed to C<foo>.
4466
4467 =item B<-q>
4468
4469 Expand double-quoted strings into the corresponding combinations of
4470 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
4471 instance, print
4472
4473     print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
4474
4475 as
4476
4477     print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
4478           . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
4479
4480 Note that the expanded form represents the way perl handles such
4481 constructions internally -- this option actually turns off the reverse
4482 translation that B::Deparse usually does. On the other hand, note that
4483 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
4484 of $y into a string before doing the assignment.
4485
4486 =item B<-s>I<LETTERS>
4487
4488 Tweak the style of B::Deparse's output. The letters should follow
4489 directly after the 's', with no space or punctuation. The following
4490 options are available:
4491
4492 =over 4
4493
4494 =item B<C>
4495
4496 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
4497
4498     if (...) {
4499          ...
4500     } else {
4501          ...
4502     }
4503
4504 instead of
4505
4506     if (...) {
4507          ...
4508     }
4509     else {
4510          ...
4511     }
4512
4513 The default is not to cuddle.
4514
4515 =item B<i>I<NUMBER>
4516
4517 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
4518
4519 =item B<T>
4520
4521 Use tabs for each 8 columns of indent. The default is to use only spaces.
4522 For instance, if the style options are B<-si4T>, a line that's indented
4523 3 times will be preceded by one tab and four spaces; if the options were
4524 B<-si8T>, the same line would be preceded by three tabs.
4525
4526 =item B<v>I<STRING>B<.>
4527
4528 Print I<STRING> for the value of a constant that can't be determined
4529 because it was optimized away (mnemonic: this happens when a constant
4530 is used in B<v>oid context). The end of the string is marked by a period.
4531 The string should be a valid perl expression, generally a constant.
4532 Note that unless it's a number, it probably needs to be quoted, and on
4533 a command line quotes need to be protected from the shell. Some
4534 conventional values include 0, 1, 42, '', 'foo', and
4535 'Useless use of constant omitted' (which may need to be
4536 B<-sv"'Useless use of constant omitted'.">
4537 or something similar depending on your shell). The default is '???'.
4538 If you're using B::Deparse on a module or other file that's require'd,
4539 you shouldn't use a value that evaluates to false, since the customary
4540 true constant at the end of a module will be in void context when the
4541 file is compiled as a main program.
4542
4543 =back
4544
4545 =item B<-x>I<LEVEL>