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