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