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