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