This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
337c173672cabf947778130ab40286310d3bc3ae
[perl5.git] / ext / B / B / Deparse.pm
1 # B::Deparse.pm
2 # Copyright (c) 1998 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';
11 use B qw(class main_root main_start main_cv svref_2object);
12 $VERSION = 0.54;
13 use strict;
14
15 # Changes between 0.50 and 0.51:
16 # - fixed nulled leave with live enter in sort { }
17 # - fixed reference constants (\"str")
18 # - handle empty programs gracefully
19 # - handle infinte loops (for (;;) {}, while (1) {})
20 # - differentiate between `for my $x ...' and `my $x; for $x ...'
21 # - various minor cleanups
22 # - moved globals into an object
23 # - added `-u', like B::C
24 # - package declarations using cop_stash
25 # - subs, formats and code sorted by cop_seq
26 # Changes between 0.51 and 0.52:
27 # - added pp_threadsv (special variables under USE_THREADS)
28 # - added documentation
29 # Changes between 0.52 and 0.53
30 # - many changes adding precedence contexts and associativity
31 # - added `-p' and `-s' output style options
32 # - various other minor fixes
33 # Changes between 0.53 and 0.54
34 # - added support for new `for (1..100)' optimization,
35 #   thanks to Gisle Aas
36
37 # Todo:
38 # - {} around variables in strings ("${var}letters")
39 # - associativity of &&=, ||=, ?:
40 # - ',' => '=>' (auto-unquote?)
41 # - break long lines ("\r" as discretionary break?)
42 # - version using op_next instead of op_first/sibling?
43 # - avoid string copies (pass arrays, one big join?)
44 # - auto-apply `-u'?
45 # - while{} with one-statement continue => for(; XXX; XXX) {}?
46 # - -uPackage:: descend recursively?
47 # - here-docs?
48 # - <DATA>?
49
50 # Object fields (were globals):
51 #
52 # avoid_local:
53 # (local($a), local($b)) and local($a, $b) have the same internal
54 # representation but the short form looks better. We notice we can
55 # use a large-scale local when checking the list, but need to prevent
56 # individual locals too. This hash holds the addresses of OPs that 
57 # have already had their local-ness accounted for. The same thing
58 # is done with my().
59 #
60 # curcv:
61 # CV for current sub (or main program) being deparsed
62 #
63 # curstash:
64 # name of the current package for deparsed code
65 #
66 # subs_todo:
67 # array of [cop_seq, GV, is_format?] for subs and formats we still
68 # want to deparse
69 #
70 # subs_done, forms_done:
71 # keys are addresses of GVs for subs and formats we've already
72 # deparsed (or at least put into subs_todo)
73 #
74 # parens: -p
75 # cuddle: ` ' or `\n', depending on -sC
76
77 # A little explanation of how precedence contexts and associativity
78 # work:
79 #
80 # deparse() calls each per-op subroutine with an argument $cx (short
81 # for context, but not the same as the cx* in the perl core), which is
82 # a number describing the op's parents in terms of precedence, whether
83 # they're inside and expression or at statement level, etc.  (see
84 # chart below). When ops with children call deparse on them, they pass
85 # along their precedence. Fractional values are used to implement
86 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
87 # parentheses hacks. The major disadvantage of this scheme is that
88 # it doesn't know about right sides and left sides, so say if you
89 # assign a listop to a variable, it can't tell it's allowed to leave
90 # the parens off the listop.
91
92 # Precedences:
93 # 26             [TODO] inside interpolation context ("")
94 # 25 left        terms and list operators (leftward)
95 # 24 left        ->
96 # 23 nonassoc    ++ --
97 # 22 right       **
98 # 21 right       ! ~ \ and unary + and -
99 # 20 left        =~ !~
100 # 19 left        * / % x
101 # 18 left        + - .
102 # 17 left        << >>
103 # 16 nonassoc    named unary operators
104 # 15 nonassoc    < > <= >= lt gt le ge
105 # 14 nonassoc    == != <=> eq ne cmp
106 # 13 left        &
107 # 12 left        | ^
108 # 11 left        &&
109 # 10 left        ||
110 #  9 nonassoc    ..  ...
111 #  8 right       ?:
112 #  7 right       = += -= *= etc.
113 #  6 left        , =>
114 #  5 nonassoc    list operators (rightward)
115 #  4 right       not
116 #  3 left        and
117 #  2 left        or xor
118 #  1             statement modifiers
119 #  0             statement level
120
121 # Nonprinting characters with special meaning:
122 # \cS - steal parens (see maybe_parens_unop)
123 # \n - newline and indent
124 # \t - increase indent
125 # \b - decrease indent (`outdent')
126 # \cK - kill following semicolon, if any
127
128 sub null {
129     my $op = shift;
130     return class($op) eq "NULL";
131 }
132
133 sub todo {
134     my $self = shift;
135     my($gv, $cv, $is_form) = @_;
136     my $seq;
137     if (!null($cv->START) and is_state($cv->START)) {
138         $seq = $cv->START->cop_seq;
139     } else {
140         $seq = 0;
141     }
142     push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
143 }
144
145 sub next_todo {
146     my $self = shift;
147     my $ent = shift @{$self->{'subs_todo'}};
148     my $name = $self->gv_name($ent->[1]);
149     if ($ent->[2]) {
150         return "format $name =\n"
151             . $self->deparse_format($ent->[1]->FORM). "\n";
152     } else {
153         return "sub $name " .
154             $self->deparse_sub($ent->[1]->CV);
155     }
156 }
157
158 sub OPf_KIDS () { 4 }
159
160 sub walk_tree {
161     my($op, $sub) = @_;
162     $sub->($op);
163     if ($op->flags & OPf_KIDS) {
164         my $kid;
165         for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
166             walk_tree($kid, $sub);
167         }
168     }
169 }
170
171 sub walk_sub {
172     my $self = shift;
173     my $cv = shift;
174     my $op = $cv->ROOT;
175     $op = shift if null $op;
176     return if !$op or null $op;
177     walk_tree($op, sub {
178         my $op = shift;
179         if ($op->ppaddr eq "pp_gv") {
180             if ($op->next->ppaddr eq "pp_entersub") {
181                 next if $self->{'subs_done'}{$ {$op->gv}}++;
182                 next if class($op->gv->CV) eq "SPECIAL";
183                 $self->todo($op->gv, $op->gv->CV, 0);
184                 $self->walk_sub($op->gv->CV);
185             } elsif ($op->next->ppaddr eq "pp_enterwrite"
186                      or ($op->next->ppaddr eq "pp_rv2gv"
187                          and $op->next->next->ppaddr eq "pp_enterwrite")) {
188                 next if $self->{'forms_done'}{$ {$op->gv}}++;
189                 next if class($op->gv->FORM) eq "SPECIAL";
190                 $self->todo($op->gv, $op->gv->FORM, 1);
191                 $self->walk_sub($op->gv->FORM);
192             }
193         }
194     });
195 }
196
197 sub stash_subs {
198     my $self = shift;
199     my $pack = shift;
200     my(%stash, @ret);
201     { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
202     my($key, $val);
203     while (($key, $val) = each %stash) {
204         next unless class($val) eq "GV";
205         if (class($val->CV) ne "SPECIAL") {
206             next if $self->{'subs_done'}{$$val}++;
207             $self->todo($val, $val->CV, 0);
208             $self->walk_sub($val->CV);
209         }
210         if (class($val->FORM) ne "SPECIAL") {
211             next if $self->{'forms_done'}{$$val}++;
212             $self->todo($val, $val->FORM, 1);
213             $self->walk_sub($val->FORM);
214         }
215     }
216 }
217
218 sub style_opts {
219     my $self = shift;
220     my $opts = shift;
221     my $opt;
222     while (length($opt = substr($opts, 0, 1))) {
223         if ($opt eq "C") {
224             $self->{'cuddle'} = " ";
225         }
226         $opts = substr($opts, 1);
227     }
228 }
229
230 sub compile {
231     my(@args) = @_;
232     return sub { 
233         my $self = bless {};
234         my $arg;
235         $self->{'subs_todo'} = [];
236         $self->stash_subs("main");
237         $self->{'curcv'} = main_cv;
238         $self->{'curstash'} = "main";
239         $self->{'cuddle'} = "\n";
240         while ($arg = shift @args) {
241             if (substr($arg, 0, 2) eq "-u") {
242                 $self->stash_subs(substr($arg, 2));
243             } elsif ($arg eq "-p") {
244                 $self->{'parens'} = 1;
245             } elsif (substr($arg, 0, 2) eq "-s") {
246                 $self->style_opts(substr $arg, 2);
247             }
248         }
249         $self->walk_sub(main_cv, main_start);
250         @{$self->{'subs_todo'}} =
251             sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
252         print indent($self->deparse(main_root, 0)), "\n" unless null main_root;
253         my @text;
254         while (scalar(@{$self->{'subs_todo'}})) {
255             push @text, $self->next_todo;
256         }
257         print indent(join("", @text)), "\n" if @text;
258     }
259 }
260
261 sub deparse {
262     my $self = shift;
263     my($op, $cx) = @_;
264 #    cluck if class($op) eq "NULL";
265     my $meth = $op->ppaddr;
266     return $self->$meth($op, $cx);
267 }
268
269 sub indent {
270     my $txt = shift;
271     my @lines = split(/\n/, $txt);
272     my $leader = "";
273     my $line;
274     for $line (@lines) {
275         if (substr($line, 0, 1) eq "\t") {
276             $leader = $leader . "    ";
277             $line = substr($line, 1);
278         } elsif (substr($line, 0, 1) eq "\b") {
279             $leader = substr($leader, 0, length($leader) - 4);
280             $line = substr($line, 1);
281         }
282         $line =~ s/\cK;?//g;
283         $line = $leader . $line;
284     }
285     return join("\n", @lines);
286 }
287
288 sub SVf_POK () {0x40000}
289
290 sub deparse_sub {
291     my $self = shift;
292     my $cv = shift;
293     my $proto = "";
294     if ($cv->FLAGS & SVf_POK) {
295         $proto = "(". $cv->PV . ") ";
296     }
297     local($self->{'curcv'}) = $cv;
298     local($self->{'curstash'}) = $self->{'curstash'};
299     if (not null $cv->ROOT) {
300         # skip leavesub
301         return $proto . "{\n\t" . 
302             $self->deparse($cv->ROOT->first, 0) . "\n\b}\n"; 
303     } else { # XSUB?
304         return $proto  . "{}\n";
305     }
306 }
307
308 sub deparse_format {
309     my $self = shift;
310     my $form = shift;
311     my @text;
312     local($self->{'curcv'}) = $form;
313     local($self->{'curstash'}) = $self->{'curstash'};
314     my $op = $form->ROOT;
315     my $kid;
316     $op = $op->first->first; # skip leavewrite, lineseq
317     while (not null $op) {
318         $op = $op->sibling; # skip nextstate
319         my @exprs;
320         $kid = $op->first->sibling; # skip pushmark
321         push @text, $kid->sv->PV;
322         $kid = $kid->sibling;
323         for (; not null $kid; $kid = $kid->sibling) {
324             push @exprs, $self->deparse($kid, 0);
325         }
326         push @text, join(", ", @exprs)."\n" if @exprs;
327         $op = $op->sibling;
328     }
329     return join("", @text) . ".";
330 }
331
332 # the aassign in-common check messes up SvCUR (always setting it
333 # to a value >= 100), but it's probably safe to assume there
334 # won't be any NULs in the names of my() variables. (with
335 # stash variables, I wouldn't be so sure)
336 sub padname_fix {
337     my $str = shift;
338     $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
339     return $str;
340 }
341
342 sub is_scope {
343     my $op = shift;
344     return $op->ppaddr eq "pp_leave" || $op->ppaddr eq "pp_scope"
345       || $op->ppaddr eq "pp_lineseq"
346         || ($op->ppaddr eq "pp_null" && class($op) eq "UNOP" 
347             && (is_scope($op->first) || $op->first->ppaddr eq "pp_enter"));
348 }
349
350 sub is_state {
351     my $name = $_[0]->ppaddr;
352     return $name eq "pp_nextstate" || $name eq "pp_dbstate";
353 }
354
355 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
356     my $op = shift;
357     return (!null($op) and null($op->sibling) 
358             and $op->ppaddr eq "pp_null" and class($op) eq "UNOP"
359             and (($op->first->ppaddr =~ /^pp_(and|or)$/
360                   and $op->first->first->sibling->ppaddr eq "pp_lineseq")
361                  or ($op->first->ppaddr eq "pp_lineseq"
362                      and not null $op->first->first->sibling
363                      and $op->first->first->sibling->ppaddr eq "pp_unstack")
364                  ));
365 }
366
367 sub is_scalar {
368     my $op = shift;
369     return ($op->ppaddr eq "pp_rv2sv" or
370             $op->ppaddr eq "pp_padsv" or
371             $op->ppaddr eq "pp_gv" or # only in array/hash constructs
372             !null($op->first) && $op->first->ppaddr eq "pp_gvsv");
373 }
374
375 sub maybe_parens {
376     my $self = shift;
377     my($text, $cx, $prec) = @_;
378     if ($prec < $cx              # unary ops nest just fine
379         or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
380         or $self->{'parens'})
381     {
382         $text = "($text)";
383         # In a unop, let parent reuse our parens; see maybe_parens_unop
384         $text = "\cS" . $text if $cx == 16;
385         return $text;
386     } else {
387         return $text;
388     }
389 }
390
391 # same as above, but get around the `if it looks like a function' rule
392 sub maybe_parens_unop {
393     my $self = shift;
394     my($name, $kid, $cx) = @_;
395     if ($cx > 16 or $self->{'parens'}) {
396         return "$name(" . $self->deparse($kid, 1) . ")";
397     } else {
398         $kid = $self->deparse($kid, 16);
399         if (substr($kid, 0, 1) eq "\cS") {
400             # use kid's parens
401             return $name . substr($kid, 1);
402         } elsif (substr($kid, 0, 1) eq "(") {
403             # avoid looks-like-a-function trap with extra parens
404             # (`+' can lead to ambiguities)
405             return "$name(" . $kid  . ")";
406         } else {
407             return "$name $kid";
408         }
409     }
410 }
411
412 sub maybe_parens_func {
413     my $self = shift;
414     my($func, $text, $cx, $prec) = @_;
415     if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
416         return "$func($text)";
417     } else {
418         return "$func $text";
419     }
420 }
421
422 sub OPp_LVAL_INTRO () { 128 }
423
424 sub maybe_local {
425     my $self = shift;
426     my($op, $cx, $text) = @_;
427     if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
428         return $self->maybe_parens_func("local", $text, $cx, 16);
429     } else {
430         return $text;
431     }
432 }
433
434 sub padname_sv {
435     my $self = shift;
436     my $targ = shift;
437     return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
438 }
439
440 sub maybe_my {
441     my $self = shift;
442     my($op, $cx, $text) = @_;
443     if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
444         return $self->maybe_parens_func("my", $text, $cx, 16);
445     } else {
446         return $text;
447     }
448 }
449
450 # The following OPs don't have functions:
451
452 # pp_padany -- does not exist after parsing
453 # pp_rcatline -- does not exist
454
455 sub pp_enter { # see also leave
456     cluck "unexpected OP_ENTER";
457     return "XXX";
458 }
459
460 sub pp_pushmark { # see also list
461     cluck "unexpected OP_PUSHMARK";
462     return "XXX";
463 }
464
465 sub pp_leavesub { # see also deparse_sub
466     cluck "unexpected OP_LEAVESUB";
467     return "XXX";
468 }
469
470 sub pp_leavewrite { # see also deparse_format
471     cluck "unexpected OP_LEAVEWRITE";
472     return "XXX";
473 }
474
475 sub pp_method { # see also entersub
476     cluck "unexpected OP_METHOD";
477     return "XXX";
478 }
479
480 sub pp_regcmaybe { # see also regcomp
481     cluck "unexpected OP_REGCMAYBE";
482     return "XXX";
483 }
484
485 sub pp_substcont { # see also subst
486     cluck "unexpected OP_SUBSTCONT";
487     return "XXX";
488 }
489
490 sub pp_grepstart { # see also grepwhile
491     cluck "unexpected OP_GREPSTART";
492     return "XXX";
493 }
494
495 sub pp_mapstart { # see also mapwhile
496     cluck "unexpected OP_MAPSTART";
497     return "XXX";
498 }
499
500 sub pp_flip { # see also flop
501     cluck "unexpected OP_FLIP";
502     return "XXX";
503 }
504
505 sub pp_iter { # see also leaveloop
506     cluck "unexpected OP_ITER";
507     return "XXX";
508 }
509
510 sub pp_enteriter { # see also leaveloop
511     cluck "unexpected OP_ENTERITER";
512     return "XXX";
513 }
514
515 sub pp_enterloop { # see also leaveloop
516     cluck "unexpected OP_ENTERLOOP";
517     return "XXX";
518 }
519
520 sub pp_leaveeval { # see also entereval
521     cluck "unexpected OP_LEAVEEVAL";
522     return "XXX";
523 }
524
525 sub pp_entertry { # see also leavetry
526     cluck "unexpected OP_ENTERTRY";
527     return "XXX";
528 }
529
530 # leave and scope/lineseq should probably share code
531 sub pp_leave {
532     my $self = shift;
533     my($op, $cx) = @_;
534     my ($kid, $expr);
535     my @exprs;
536     local($self->{'curstash'}) = $self->{'curstash'};
537     $kid = $op->first->sibling; # skip enter
538     if (is_miniwhile($kid)) {
539         my $top = $kid->first;
540         my $name = $top->ppaddr;
541         if ($name eq "pp_and") {
542             $name = "while";
543         } elsif ($name eq "pp_or") {
544             $name = "until";
545         } else { # no conditional -> while 1 or until 0
546             return $self->deparse($top->first, 1) . " while 1";
547         }
548         my $cond = $top->first;
549         my $body = $cond->sibling->first; # skip lineseq
550         $cond = $self->deparse($cond, 1);
551         $body = $self->deparse($body, 1);
552         return "$body $name $cond";
553     }
554     for (; !null($kid); $kid = $kid->sibling) {
555         $expr = "";
556         if (is_state $kid) {
557             $expr = $self->deparse($kid, 0);
558             $kid = $kid->sibling;
559             last if null $kid;
560         }
561         $expr .= $self->deparse($kid, 0);
562         push @exprs, $expr if $expr;
563     }
564     if ($cx > 0) { # inside an expression
565         return "do { " . join(";\n", @exprs) . " }";
566     } else {
567         return join(";\n", @exprs);     
568     }
569 }
570
571 sub pp_scope {
572     my $self = shift;
573     my($op, $cx) = @_;
574     my ($kid, $expr);
575     my @exprs;
576     for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
577         $expr = "";
578         if (is_state $kid) {
579             $expr = $self->deparse($kid, 0);
580             $kid = $kid->sibling;
581             last if null $kid;
582         }
583         $expr .= $self->deparse($kid, 0);
584         push @exprs, $expr if $expr;
585     }
586     if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
587         return "do { " . join(";\n", @exprs) . " }";
588     } else {
589         return join(";\n", @exprs);     
590     }
591 }
592
593 sub pp_lineseq { pp_scope(@_) }
594
595 # The BEGIN {} is used here because otherwise this code isn't executed
596 # when you run B::Deparse on itself.
597 my %globalnames;
598 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
599             "ENV", "ARGV", "ARGVOUT", "_"); }
600
601 sub gv_name {
602     my $self = shift;
603     my $gv = shift;
604     my $stash = $gv->STASH->NAME;
605     my $name = $gv->NAME;
606     if ($stash eq $self->{'curstash'} or $globalnames{$name}
607         or $name =~ /^[^A-Za-z_]/)
608     {
609         $stash = "";
610     } else {
611         $stash = $stash . "::";
612     }
613     if ($name =~ /^([\cA-\cZ])$/) {
614         $name = "^" . chr(64 + ord($1));
615     }
616     return $stash . $name;
617 }
618
619 # Notice how subs and formats are inserted between statements here
620 sub pp_nextstate {
621     my $self = shift;
622     my($op, $cx) = @_;
623     my @text;
624     @text = $op->label . ": " if $op->label;
625     my $seq = $op->cop_seq;
626     while (scalar(@{$self->{'subs_todo'}})
627            and $seq > $self->{'subs_todo'}[0][0]) {
628         push @text, $self->next_todo;
629     }
630     my $stash = $op->stash->NAME;
631     if ($stash ne $self->{'curstash'}) {
632         push @text, "package $stash;\n";
633         $self->{'curstash'} = $stash;
634     }
635     return join("", @text);
636 }
637
638 sub pp_dbstate { pp_nextstate(@_) }
639
640 sub pp_unstack { return "" } # see also leaveloop
641
642 sub baseop {
643     my $self = shift;
644     my($op, $cx, $name) = @_;
645     return $name;
646 }
647
648 sub pp_stub { baseop(@_, "()") }
649 sub pp_wantarray { baseop(@_, "wantarray") }
650 sub pp_fork { baseop(@_, "fork") }
651 sub pp_wait { baseop(@_, "wait") }
652 sub pp_getppid { baseop(@_, "getppid") }
653 sub pp_time { baseop(@_, "time") }
654 sub pp_tms { baseop(@_, "times") }
655 sub pp_ghostent { baseop(@_, "gethostent") }
656 sub pp_gnetent { baseop(@_, "getnetent") }
657 sub pp_gprotoent { baseop(@_, "getprotoent") }
658 sub pp_gservent { baseop(@_, "getservent") }
659 sub pp_ehostent { baseop(@_, "endhostent") }
660 sub pp_enetent { baseop(@_, "endnetent") }
661 sub pp_eprotoent { baseop(@_, "endprotoent") }
662 sub pp_eservent { baseop(@_, "endservent") }
663 sub pp_gpwent { baseop(@_, "getpwent") }
664 sub pp_spwent { baseop(@_, "setpwent") }
665 sub pp_epwent { baseop(@_, "endpwent") }
666 sub pp_ggrent { baseop(@_, "getgrent") }
667 sub pp_sgrent { baseop(@_, "setgrent") }
668 sub pp_egrent { baseop(@_, "endgrent") }
669 sub pp_getlogin { baseop(@_, "getlogin") }
670
671 sub POSTFIX () { 1 }
672
673 # I couldn't think of a good short name, but this is the category of
674 # symbolic unary operators with interesting precedence
675
676 sub pfixop {
677     my $self = shift;
678     my($op, $cx, $name, $prec, $flags) = (@_, 0);
679     my $kid = $op->first;
680     $kid = $self->deparse($kid, $prec);
681     return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
682                                $cx, $prec);
683 }
684
685 sub pp_preinc { pfixop(@_, "++", 23) }
686 sub pp_predec { pfixop(@_, "--", 23) }
687 sub pp_postinc { pfixop(@_, "++", 23, POSTFIX) }
688 sub pp_postdec { pfixop(@_, "--", 23, POSTFIX) }
689 sub pp_i_preinc { pfixop(@_, "++", 23) }
690 sub pp_i_predec { pfixop(@_, "--", 23) }
691 sub pp_i_postinc { pfixop(@_, "++", 23, POSTFIX) }
692 sub pp_i_postdec { pfixop(@_, "--", 23, POSTFIX) }
693 sub pp_complement { pfixop(@_, "~", 21) }
694
695 sub pp_negate {
696     my $self = shift;
697     my($op, $cx) = @_;
698     if ($op->first->ppaddr =~ /^pp_(i_)?negate$/) {
699         # avoid --$x
700         $self->pfixop($op, $cx, "-", 21.5);
701     } else {
702         $self->pfixop($op, $cx, "-", 21);       
703     }
704 }
705 sub pp_i_negate { pp_negate(@_) }
706
707 sub pp_not {
708     my $self = shift;
709     my($op, $cx) = @_;
710     if ($cx <= 4) {
711         $self->pfixop($op, $cx, "not ", 4);
712     } else {
713         $self->pfixop($op, $cx, "!", 21);       
714     }
715 }
716
717 sub OPf_SPECIAL () { 128 }
718
719 sub unop {
720     my $self = shift;
721     my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
722     my $kid;
723     if ($op->flags & OPf_KIDS) {
724         $kid = $op->first;
725         return $self->maybe_parens_unop($name, $kid, $cx);
726     } else {
727         return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");       
728     }
729 }
730
731 sub pp_chop { unop(@_, "chop") }
732 sub pp_chomp { unop(@_, "chomp") }
733 sub pp_schop { unop(@_, "chop") }
734 sub pp_schomp { unop(@_, "chomp") }
735 sub pp_defined { unop(@_, "defined") }
736 sub pp_undef { unop(@_, "undef") }
737 sub pp_study { unop(@_, "study") }
738 sub pp_ref { unop(@_, "ref") }
739 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
740
741 sub pp_sin { unop(@_, "sin") }
742 sub pp_cos { unop(@_, "cos") }
743 sub pp_rand { unop(@_, "rand") }
744 sub pp_srand { unop(@_, "srand") }
745 sub pp_exp { unop(@_, "exp") }
746 sub pp_log { unop(@_, "log") }
747 sub pp_sqrt { unop(@_, "sqrt") }
748 sub pp_int { unop(@_, "int") }
749 sub pp_hex { unop(@_, "hex") }
750 sub pp_oct { unop(@_, "oct") }
751 sub pp_abs { unop(@_, "abs") }
752
753 sub pp_length { unop(@_, "length") }
754 sub pp_ord { unop(@_, "ord") }
755 sub pp_chr { unop(@_, "chr") }
756 sub pp_ucfirst { unop(@_, "ucfirst") }
757 sub pp_lcfirst { unop(@_, "lcfirst") }
758 sub pp_uc { unop(@_, "uc") }
759 sub pp_lc { unop(@_, "lc") }
760 sub pp_quotemeta { unop(@_, "quotemeta") }
761
762 sub pp_each { unop(@_, "each") }
763 sub pp_values { unop(@_, "values") }
764 sub pp_keys { unop(@_, "keys") }
765 sub pp_pop { unop(@_, "pop") }
766 sub pp_shift { unop(@_, "shift") }
767
768 sub pp_caller { unop(@_, "caller") }
769 sub pp_reset { unop(@_, "reset") }
770 sub pp_exit { unop(@_, "exit") }
771 sub pp_prototype { unop(@_, "prototype") }
772
773 sub pp_close { unop(@_, "close") }
774 sub pp_fileno { unop(@_, "fileno") }
775 sub pp_umask { unop(@_, "umask") }
776 sub pp_binmode { unop(@_, "binmode") }
777 sub pp_untie { unop(@_, "untie") }
778 sub pp_tied { unop(@_, "tied") }
779 sub pp_dbmclose { unop(@_, "dbmclose") }
780 sub pp_getc { unop(@_, "getc") }
781 sub pp_eof { unop(@_, "eof") }
782 sub pp_tell { unop(@_, "tell") }
783 sub pp_getsockname { unop(@_, "getsockname") }
784 sub pp_getpeername { unop(@_, "getpeername") }
785
786 sub pp_chdir { unop(@_, "chdir") }
787 sub pp_chroot { unop(@_, "chroot") }
788 sub pp_readlink { unop(@_, "readlink") }
789 sub pp_rmdir { unop(@_, "rmdir") }
790 sub pp_readdir { unop(@_, "readdir") }
791 sub pp_telldir { unop(@_, "telldir") }
792 sub pp_rewinddir { unop(@_, "rewinddir") }
793 sub pp_closedir { unop(@_, "closedir") }
794 sub pp_getpgrp { unop(@_, "getpgrp") }
795 sub pp_localtime { unop(@_, "localtime") }
796 sub pp_gmtime { unop(@_, "gmtime") }
797 sub pp_alarm { unop(@_, "alarm") }
798 sub pp_sleep { unop(@_, "sleep") }
799
800 sub pp_dofile { unop(@_, "do") }
801 sub pp_entereval { unop(@_, "eval") }
802
803 sub pp_ghbyname { unop(@_, "gethostbyname") }
804 sub pp_gnbyname { unop(@_, "getnetbyname") }
805 sub pp_gpbyname { unop(@_, "getprotobyname") }
806 sub pp_shostent { unop(@_, "sethostent") }
807 sub pp_snetent { unop(@_, "setnetent") }
808 sub pp_sprotoent { unop(@_, "setprotoent") }
809 sub pp_sservent { unop(@_, "setservent") }
810 sub pp_gpwnam { unop(@_, "getpwnam") }
811 sub pp_gpwuid { unop(@_, "getpwuid") }
812 sub pp_ggrnam { unop(@_, "getgrnam") }
813 sub pp_ggrgid { unop(@_, "getgrgid") }
814
815 sub pp_lock { unop(@_, "lock") }
816
817 sub pp_exists {
818     my $self = shift;
819     my($op, $cx) = @_;
820     return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
821                                     $cx, 16);
822 }
823
824 sub OPpSLICE () { 64 }
825
826 sub pp_delete {
827     my $self = shift;
828     my($op, $cx) = @_;
829     my $arg;
830     if ($op->private & OPpSLICE) {
831         return $self->maybe_parens_func("delete",
832                                         $self->pp_hslice($op->first, 16),
833                                         $cx, 16);
834     } else {
835         return $self->maybe_parens_func("delete",
836                                         $self->pp_helem($op->first, 16),
837                                         $cx, 16);
838     }
839 }
840
841 sub OPp_CONST_BARE () { 64 }
842
843 sub pp_require {
844     my $self = shift;
845     my($op, $cx) = @_;
846     if (class($op) eq "UNOP" and $op->first->ppaddr eq "pp_const"
847         and $op->first->private & OPp_CONST_BARE)
848     {
849         my $name = $op->first->sv->PV;
850         $name =~ s[/][::]g;
851         $name =~ s/\.pm//g;
852         return "require($name)";
853     } else {    
854         $self->unop($op, $cx, "require");
855     }
856 }
857
858 sub pp_scalar { 
859     my $self = shift;
860     my($op, $cv) = @_;
861     my $kid = $op->first;
862     if (not null $kid->sibling) {
863         # XXX Was a here-doc
864         return $self->dquote($op);
865     }
866     $self->unop(@_, "scalar");
867 }
868
869
870 sub padval {
871     my $self = shift;
872     my $targ = shift;
873     return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
874 }
875
876 sub OPf_REF () { 16 }
877
878 sub pp_refgen {
879     my $self = shift;   
880     my($op, $cx) = @_;
881     my $kid = $op->first;
882     if ($kid->ppaddr eq "pp_null") {
883         $kid = $kid->first;
884         if ($kid->ppaddr eq "pp_anonlist" || $kid->ppaddr eq "pp_anonhash") {
885             my($pre, $post) = @{{"pp_anonlist" => ["[","]"],
886                                  "pp_anonhash" => ["{","}"]}->{$kid->ppaddr}};
887             my($expr, @exprs);
888             $kid = $kid->first->sibling; # skip pushmark
889             for (; !null($kid); $kid = $kid->sibling) {
890                 $expr = $self->deparse($kid, 6);
891                 push @exprs, $expr;
892             }
893             return $pre . join(", ", @exprs) . $post;
894         } elsif (!null($kid->sibling) and 
895                  $kid->sibling->ppaddr eq "pp_anoncode") {
896             return "sub " .
897                 $self->deparse_sub($self->padval($kid->sibling->targ));
898         } elsif ($kid->ppaddr eq "pp_pushmark"
899                  and $kid->sibling->ppaddr =~ /^pp_(pad|rv2)[ah]v$/
900                  and not $kid->sibling->flags & OPf_REF) {
901             # The @a in \(@a) isn't in ref context, but only when the
902             # parens are there.
903             return "\\(" . $self->deparse($kid->sibling, 1) . ")";
904         }
905     }
906     $self->pfixop($op, $cx, "\\", 20);
907 }
908
909 sub pp_srefgen { pp_refgen(@_) }
910
911 sub pp_readline {
912     my $self = shift;
913     my($op, $cx) = @_;
914     my $kid = $op->first;
915     $kid = $kid->first if $kid->ppaddr eq "pp_rv2gv"; # <$fh>
916     if ($kid->ppaddr eq "pp_rv2gv") {
917         $kid = $kid->first;
918     }
919     return "<" . $self->deparse($kid, 1) . ">";
920 }
921
922 sub loopex {
923     my $self = shift;
924     my ($op, $cx, $name) = @_;
925     if (class($op) eq "PVOP") {
926         return "$name " . $op->pv;
927     } elsif (class($op) eq "OP") {
928         return $name;
929     } elsif (class($op) eq "UNOP") {
930         # Note -- loop exits are actually exempt from the
931         # looks-like-a-func rule, but a few extra parens won't hurt
932         return $self->maybe_parens_unop($name, $op->first, $cx);
933     }
934 }
935
936 sub pp_last { loopex(@_, "last") }
937 sub pp_next { loopex(@_, "next") }
938 sub pp_redo { loopex(@_, "redo") }
939 sub pp_goto { loopex(@_, "goto") }
940 sub pp_dump { loopex(@_, "dump") }
941
942 sub ftst {
943     my $self = shift;
944     my($op, $cx, $name) = @_;
945     if (class($op) eq "UNOP") {
946         # Genuine `-X' filetests are exempt from the LLAFR, but not
947         # l?stat(); for the sake of clarity, give'em all parens
948         return $self->maybe_parens_unop($name, $op->first, $cx);
949     } elsif (class($op) eq "GVOP") {
950         return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
951     } else { # I don't think baseop filetests ever survive ck_ftst, but...
952         return $name;
953     }
954 }
955
956 sub pp_lstat { ftst(@_, "lstat") }
957 sub pp_stat { ftst(@_, "stat") }
958 sub pp_ftrread { ftst(@_, "-R") }
959 sub pp_ftrwrite { ftst(@_, "-W") }
960 sub pp_ftrexec { ftst(@_, "-X") }
961 sub pp_fteread { ftst(@_, "-r") }
962 sub pp_ftewrite { ftst(@_, "-r") }
963 sub pp_fteexec { ftst(@_, "-r") }
964 sub pp_ftis { ftst(@_, "-e") }
965 sub pp_fteowned { ftst(@_, "-O") }
966 sub pp_ftrowned { ftst(@_, "-o") }
967 sub pp_ftzero { ftst(@_, "-z") }
968 sub pp_ftsize { ftst(@_, "-s") }
969 sub pp_ftmtime { ftst(@_, "-M") }
970 sub pp_ftatime { ftst(@_, "-A") }
971 sub pp_ftctime { ftst(@_, "-C") }
972 sub pp_ftsock { ftst(@_, "-S") }
973 sub pp_ftchr { ftst(@_, "-c") }
974 sub pp_ftblk { ftst(@_, "-b") }
975 sub pp_ftfile { ftst(@_, "-f") }
976 sub pp_ftdir { ftst(@_, "-d") }
977 sub pp_ftpipe { ftst(@_, "-p") }
978 sub pp_ftlink { ftst(@_, "-l") }
979 sub pp_ftsuid { ftst(@_, "-u") }
980 sub pp_ftsgid { ftst(@_, "-g") }
981 sub pp_ftsvtx { ftst(@_, "-k") }
982 sub pp_fttty { ftst(@_, "-t") }
983 sub pp_fttext { ftst(@_, "-T") }
984 sub pp_ftbinary { ftst(@_, "-B") }
985
986 sub SWAP_CHILDREN () { 1 }
987 sub ASSIGN () { 2 } # has OP= variant
988
989 sub OPf_STACKED () { 64 }
990
991 my(%left, %right);
992
993 sub assoc_class {
994     my $op = shift;
995     my $name = $op->ppaddr;
996     if ($name eq "pp_concat" and $op->first->ppaddr eq "pp_concat") {
997         # avoid spurious `=' -- see comment in pp_concat
998         return "pp_concat";
999     }
1000     if ($name eq "pp_null" and class($op) eq "UNOP"
1001         and $op->first->ppaddr =~ /^pp_(and|x?or)$/
1002         and null $op->first->sibling)
1003     {
1004         # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1005         # with a null that's used as the common end point of the two
1006         # flows of control. For precedence purposes, ignore it.
1007         # (COND_EXPRs have these too, but we don't bother with
1008         # their associativity).
1009         return assoc_class($op->first);
1010     }
1011     return $name . ($op->flags & OPf_STACKED ? "=" : "");
1012 }
1013
1014 # Left associative operators, like `+', for which
1015 # $a + $b + $c is equivalent to ($a + $b) + $c
1016
1017 BEGIN {
1018     %left = ('pp_multiply' => 19, 'pp_i_multiply' => 19,
1019              'pp_divide' => 19, 'pp_i_divide' => 19,
1020              'pp_modulo' => 19, 'pp_i_modulo' => 19,
1021              'pp_repeat' => 19,
1022              'pp_add' => 18, 'pp_i_add' => 18,
1023              'pp_subtract' => 18, 'pp_i_subtract' => 18,
1024              'pp_concat' => 18,
1025              'pp_left_shift' => 17, 'pp_right_shift' => 17,
1026              'pp_bit_and' => 13,
1027              'pp_bit_or' => 12, 'pp_bit_xor' => 12,
1028              'pp_and' => 3,
1029              'pp_or' => 2, 'pp_xor' => 2,
1030             );
1031 }
1032
1033 sub deparse_binop_left {
1034     my $self = shift;
1035     my($op, $left, $prec) = @_;
1036     if ($left{assoc_class($op)}
1037         and $left{assoc_class($op)} == $left{assoc_class($left)})
1038     {
1039         return $self->deparse($left, $prec - .00001);
1040     } else {
1041         return $self->deparse($left, $prec);    
1042     }
1043 }
1044
1045 # Right associative operators, like `=', for which
1046 # $a = $b = $c is equivalent to $a = ($b = $c)
1047
1048 BEGIN {
1049     %right = ('pp_pow' => 22,
1050               'pp_sassign=' => 7, 'pp_aassign=' => 7,
1051               'pp_multiply=' => 7, 'pp_i_multiply=' => 7,
1052               'pp_divide=' => 7, 'pp_i_divide=' => 7,
1053               'pp_modulo=' => 7, 'pp_i_modulo=' => 7,
1054               'pp_repeat=' => 7,
1055               'pp_add=' => 7, 'pp_i_add=' => 7,
1056               'pp_subtract=' => 7, 'pp_i_subtract=' => 7,
1057               'pp_concat=' => 7,
1058               'pp_left_shift=' => 7, 'pp_right_shift=' => 7,
1059               'pp_bit_and=' => 7,
1060               'pp_bit_or=' => 7, 'pp_bit_xor=' => 7,
1061               'pp_andassign' => 7,
1062               'pp_orassign' => 7,
1063              );
1064 }
1065
1066 sub deparse_binop_right {
1067     my $self = shift;
1068     my($op, $right, $prec) = @_;
1069     if ($right{assoc_class($op)}
1070         and $right{assoc_class($op)} == $right{assoc_class($right)})
1071     {
1072         return $self->deparse($right, $prec - .00001);
1073     } else {
1074         return $self->deparse($right, $prec);   
1075     }
1076 }
1077
1078 sub binop {
1079     my $self = shift;
1080     my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1081     my $left = $op->first;
1082     my $right = $op->last;
1083     my $eq = "";
1084     if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1085         $eq = "=";
1086         $prec = 7;
1087     }
1088     if ($flags & SWAP_CHILDREN) {
1089         ($left, $right) = ($right, $left);
1090     }
1091     $left = $self->deparse_binop_left($op, $left, $prec);
1092     $right = $self->deparse_binop_right($op, $right, $prec);
1093     return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1094 }
1095
1096 sub pp_add { binop(@_, "+", 18, ASSIGN) }
1097 sub pp_multiply { binop(@_, "*", 19, ASSIGN) }
1098 sub pp_subtract { binop(@_, "-",18,  ASSIGN) }
1099 sub pp_divide { binop(@_, "/", 19, ASSIGN) }
1100 sub pp_modulo { binop(@_, "%", 19, ASSIGN) }
1101 sub pp_i_add { binop(@_, "+", 18, ASSIGN) }
1102 sub pp_i_multiply { binop(@_, "*", 19, ASSIGN) }
1103 sub pp_i_subtract { binop(@_, "-", 18, ASSIGN) }
1104 sub pp_i_divide { binop(@_, "/", 19, ASSIGN) }
1105 sub pp_i_modulo { binop(@_, "%", 19, ASSIGN) }
1106 sub pp_pow { binop(@_, "**", 22, ASSIGN) }
1107
1108 sub pp_left_shift { binop(@_, "<<", 17, ASSIGN) }
1109 sub pp_right_shift { binop(@_, ">>", 17, ASSIGN) }
1110 sub pp_bit_and { binop(@_, "&", 13, ASSIGN) }
1111 sub pp_bit_or { binop(@_, "|", 12, ASSIGN) }
1112 sub pp_bit_xor { binop(@_, "^", 12, ASSIGN) }
1113
1114 sub pp_eq { binop(@_, "==", 14) }
1115 sub pp_ne { binop(@_, "!=", 14) }
1116 sub pp_lt { binop(@_, "<", 15) }
1117 sub pp_gt { binop(@_, ">", 15) }
1118 sub pp_ge { binop(@_, ">=", 15) }
1119 sub pp_le { binop(@_, "<=", 15) }
1120 sub pp_ncmp { binop(@_, "<=>", 14) }
1121 sub pp_i_eq { binop(@_, "==", 14) }
1122 sub pp_i_ne { binop(@_, "!=", 14) }
1123 sub pp_i_lt { binop(@_, "<", 15) }
1124 sub pp_i_gt { binop(@_, ">", 15) }
1125 sub pp_i_ge { binop(@_, ">=", 15) }
1126 sub pp_i_le { binop(@_, "<=", 15) }
1127 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1128
1129 sub pp_seq { binop(@_, "eq", 14) }
1130 sub pp_sne { binop(@_, "ne", 14) }
1131 sub pp_slt { binop(@_, "lt", 15) }
1132 sub pp_sgt { binop(@_, "gt", 15) }
1133 sub pp_sge { binop(@_, "ge", 15) }
1134 sub pp_sle { binop(@_, "le", 15) }
1135 sub pp_scmp { binop(@_, "cmp", 14) }
1136
1137 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1138 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1139
1140 # `.' is special because concats-of-concats are optimized to save copying
1141 # by making all but the first concat stacked. The effect is as if the
1142 # programmer had written `($a . $b) .= $c', except legal.
1143 sub pp_concat {
1144     my $self = shift;
1145     my($op, $cx) = @_;
1146     my $left = $op->first;
1147     my $right = $op->last;
1148     my $eq = "";
1149     my $prec = 18;
1150     if ($op->flags & OPf_STACKED and $op->first->ppaddr ne "pp_concat") {
1151         $eq = "=";
1152         $prec = 7;
1153     }
1154     $left = $self->deparse_binop_left($op, $left, $prec);
1155     $right = $self->deparse_binop_right($op, $right, $prec);
1156     return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1157 }
1158
1159 # `x' is weird when the left arg is a list
1160 sub pp_repeat {
1161     my $self = shift;
1162     my($op, $cx) = @_;
1163     my $left = $op->first;
1164     my $right = $op->last;
1165     my $eq = "";
1166     my $prec = 19;
1167     if ($op->flags & OPf_STACKED) {
1168         $eq = "=";
1169         $prec = 7;
1170     }
1171     if (null($right)) { # list repeat; count is inside left-side ex-list
1172         my $kid = $left->first->sibling; # skip pushmark
1173         my @exprs;
1174         for (; !null($kid->sibling); $kid = $kid->sibling) {
1175             push @exprs, $self->deparse($kid, 6);
1176         }
1177         $right = $kid;
1178         $left = "(" . join(", ", @exprs). ")";
1179     } else {
1180         $left = $self->deparse_binop_left($op, $left, $prec);
1181     }
1182     $right = $self->deparse_binop_right($op, $right, $prec);
1183     return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1184 }
1185
1186 sub range {
1187     my $self = shift;
1188     my ($op, $cx, $type) = @_;
1189     my $left = $op->first;
1190     my $right = $left->sibling;
1191     $left = $self->deparse($left, 9);
1192     $right = $self->deparse($right, 9);
1193     return $self->maybe_parens("$left $type $right", $cx, 9);
1194 }
1195
1196 sub pp_flop {
1197     my $self = shift;
1198     my($op, $cx) = @_;
1199     my $flip = $op->first;
1200     my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1201     return $self->range($flip->first, $cx, $type);
1202 }
1203
1204 # one-line while/until is handled in pp_leave
1205
1206 sub logop {
1207     my $self = shift;
1208     my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1209     my $left = $op->first;
1210     my $right = $op->first->sibling;
1211     if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
1212         $left = $self->deparse($left, 1);
1213         $right = $self->deparse($right, 0);
1214         return "$blockname ($left) {\n\t$right\n\b}\cK";
1215     } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
1216         $right = $self->deparse($right, 1);
1217         $left = $self->deparse($left, 1);
1218         return "$right $blockname $left";
1219     } elsif ($cx > $lowprec and $highop) { # $a && $b
1220         $left = $self->deparse_binop_left($op, $left, $highprec);
1221         $right = $self->deparse_binop_right($op, $right, $highprec);
1222         return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1223     } else { # $a and $b
1224         $left = $self->deparse_binop_left($op, $left, $lowprec);
1225         $right = $self->deparse_binop_right($op, $right, $lowprec);
1226         return $self->maybe_parens("$left $lowop $right", $cx, $lowprec); 
1227     }
1228 }
1229
1230 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1231 sub pp_or {  logop(@_, "or",  2, "||", 10, "unless") }
1232 sub pp_xor { logop(@_, "xor", 2, "",   0,  "") }
1233
1234 sub logassignop {
1235     my $self = shift;
1236     my ($op, $cx, $opname) = @_;
1237     my $left = $op->first;
1238     my $right = $op->first->sibling->first; # skip sassign
1239     $left = $self->deparse($left, 7);
1240     $right = $self->deparse($right, 7);
1241     return $self->maybe_parens("$left $opname $right", $cx, 7);
1242 }
1243
1244 sub pp_andassign { logassignop(@_, "&&=") }
1245 sub pp_orassign { logassignop(@_, "||=") }
1246
1247 sub listop {
1248     my $self = shift;
1249     my($op, $cx, $name) = @_;
1250     my(@exprs);
1251     my $parens = ($cx >= 5) || $self->{'parens'};
1252     my $kid = $op->first->sibling;
1253     return $name if null $kid;
1254     my $first = $self->deparse($kid, 6);
1255     $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1256     push @exprs, $first;
1257     $kid = $kid->sibling;
1258     for (; !null($kid); $kid = $kid->sibling) {
1259         push @exprs, $self->deparse($kid, 6);
1260     }
1261     if ($parens) {
1262         return "$name(" . join(", ", @exprs) . ")";
1263     } else {
1264         return "$name " . join(", ", @exprs);
1265     }
1266 }
1267
1268 sub pp_bless { listop(@_, "bless") }
1269 sub pp_atan2 { listop(@_, "atan2") }
1270 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1271 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1272 sub pp_index { listop(@_, "index") }
1273 sub pp_rindex { listop(@_, "rindex") }
1274 sub pp_sprintf { listop(@_, "sprintf") }
1275 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1276 sub pp_crypt { listop(@_, "crypt") }
1277 sub pp_unpack { listop(@_, "unpack") }
1278 sub pp_pack { listop(@_, "pack") }
1279 sub pp_join { listop(@_, "join") }
1280 sub pp_splice { listop(@_, "splice") }
1281 sub pp_push { listop(@_, "push") }
1282 sub pp_unshift { listop(@_, "unshift") }
1283 sub pp_reverse { listop(@_, "reverse") }
1284 sub pp_warn { listop(@_, "warn") }
1285 sub pp_die { listop(@_, "die") }
1286 # Actually, return is exempt from the LLAFR (see examples in this very
1287 # module!), but for consistency's sake, ignore that fact
1288 sub pp_return { listop(@_, "return") }
1289 sub pp_open { listop(@_, "open") }
1290 sub pp_pipe_op { listop(@_, "pipe") }
1291 sub pp_tie { listop(@_, "tie") }
1292 sub pp_dbmopen { listop(@_, "dbmopen") }
1293 sub pp_sselect { listop(@_, "select") }
1294 sub pp_select { listop(@_, "select") }
1295 sub pp_read { listop(@_, "read") }
1296 sub pp_sysopen { listop(@_, "sysopen") }
1297 sub pp_sysseek { listop(@_, "sysseek") }
1298 sub pp_sysread { listop(@_, "sysread") }
1299 sub pp_syswrite { listop(@_, "syswrite") }
1300 sub pp_send { listop(@_, "send") }
1301 sub pp_recv { listop(@_, "recv") }
1302 sub pp_seek { listop(@_, "seek") }
1303 sub pp_truncate { listop(@_, "truncate") }
1304 sub pp_fcntl { listop(@_, "fcntl") }
1305 sub pp_ioctl { listop(@_, "ioctl") }
1306 sub pp_flock { listop(@_, "flock") }
1307 sub pp_socket { listop(@_, "socket") }
1308 sub pp_sockpair { listop(@_, "sockpair") }
1309 sub pp_bind { listop(@_, "bind") }
1310 sub pp_connect { listop(@_, "connect") }
1311 sub pp_listen { listop(@_, "listen") }
1312 sub pp_accept { listop(@_, "accept") }
1313 sub pp_shutdown { listop(@_, "shutdown") }
1314 sub pp_gsockopt { listop(@_, "getsockopt") }
1315 sub pp_ssockopt { listop(@_, "setsockopt") }
1316 sub pp_chown { listop(@_, "chown") }
1317 sub pp_unlink { listop(@_, "unlink") }
1318 sub pp_chmod { listop(@_, "chmod") }
1319 sub pp_utime { listop(@_, "utime") }
1320 sub pp_rename { listop(@_, "rename") }
1321 sub pp_link { listop(@_, "link") }
1322 sub pp_symlink { listop(@_, "symlink") }
1323 sub pp_mkdir { listop(@_, "mkdir") }
1324 sub pp_open_dir { listop(@_, "opendir") }
1325 sub pp_seekdir { listop(@_, "seekdir") }
1326 sub pp_waitpid { listop(@_, "waitpid") }
1327 sub pp_system { listop(@_, "system") }
1328 sub pp_exec { listop(@_, "exec") }
1329 sub pp_kill { listop(@_, "kill") }
1330 sub pp_setpgrp { listop(@_, "setpgrp") }
1331 sub pp_getpriority { listop(@_, "getpriority") }
1332 sub pp_setpriority { listop(@_, "setpriority") }
1333 sub pp_shmget { listop(@_, "shmget") }
1334 sub pp_shmctl { listop(@_, "shmctl") }
1335 sub pp_shmread { listop(@_, "shmread") }
1336 sub pp_shmwrite { listop(@_, "shmwrite") }
1337 sub pp_msgget { listop(@_, "msgget") }
1338 sub pp_msgctl { listop(@_, "msgctl") }
1339 sub pp_msgsnd { listop(@_, "msgsnd") }
1340 sub pp_msgrcv { listop(@_, "msgrcv") }
1341 sub pp_semget { listop(@_, "semget") }
1342 sub pp_semctl { listop(@_, "semctl") }
1343 sub pp_semop { listop(@_, "semop") }
1344 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1345 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1346 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1347 sub pp_gsbyname { listop(@_, "getservbyname") }
1348 sub pp_gsbyport { listop(@_, "getservbyport") }
1349 sub pp_syscall { listop(@_, "syscall") }
1350
1351 sub pp_glob {
1352     my $self = shift;
1353     my($op, $cx) = @_;
1354     my $text = $self->dq($op->first->sibling);  # skip pushmark
1355     if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1356         or $text =~ /[<>]/) { 
1357         return 'glob(' . single_delim('qq', '"', $text) . ')';
1358     } else {
1359         return '<' . $text . '>';
1360     }
1361 }
1362
1363 sub indirop {
1364     my $self = shift;
1365     my($op, $cx, $name) = @_;
1366     my($expr, @exprs);
1367     my $kid = $op->first->sibling;
1368     my $indir = "";
1369     if ($op->flags & OPf_STACKED) {
1370         $indir = $kid;
1371         $indir = $indir->first; # skip rv2gv
1372         if (is_scope($indir)) {
1373             $indir = "{" . $self->deparse($indir, 0) . "}";
1374         } else {
1375             $indir = $self->deparse($indir, 24);
1376         }
1377         $indir = $indir . " ";
1378         $kid = $kid->sibling;
1379     }
1380     for (; !null($kid); $kid = $kid->sibling) {
1381         $expr = $self->deparse($kid, 6);
1382         push @exprs, $expr;
1383     }
1384     return $self->maybe_parens_func($name,
1385                                     $indir . join(", ", @exprs),
1386                                     $cx, 5);
1387 }
1388
1389 sub pp_prtf { indirop(@_, "printf") }
1390 sub pp_print { indirop(@_, "print") }
1391 sub pp_sort { indirop(@_, "sort") }
1392
1393 sub mapop {
1394     my $self = shift;
1395     my($op, $cx, $name) = @_;
1396     my($expr, @exprs);
1397     my $kid = $op->first; # this is the (map|grep)start
1398     $kid = $kid->first->sibling; # skip a pushmark
1399     my $code = $kid->first; # skip a null
1400     if (is_scope $code) {
1401         $code = "{" . $self->deparse($code, 1) . "} ";
1402     } else {
1403         $code = $self->deparse($code, 24) . ", ";
1404     }
1405     $kid = $kid->sibling;
1406     for (; !null($kid); $kid = $kid->sibling) {
1407         $expr = $self->deparse($kid, 6);
1408         push @exprs, $expr if $expr;
1409     }
1410     return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1411 }
1412
1413 sub pp_mapwhile { mapop(@_, "map") }   
1414 sub pp_grepwhile { mapop(@_, "grep") }   
1415
1416 sub pp_list {
1417     my $self = shift;
1418     my($op, $cx) = @_;
1419     my($expr, @exprs);
1420     my $kid = $op->first->sibling; # skip pushmark
1421     return $self->deparse($kid, $cx) if null $kid->sibling;
1422     my $lop;
1423     my $local = "either"; # could be local(...) or my(...)
1424     for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1425         # This assumes that no other private flags equal 128, and that
1426         # OPs that store things other than flags in their op_private,
1427         # like OP_AELEMFAST, won't be immediate children of a list.
1428         unless ($lop->private & OPp_LVAL_INTRO or $lop->ppaddr eq "pp_undef")
1429         {
1430             $local = ""; # or not
1431             last;
1432         }
1433         if ($lop->ppaddr =~ /^pp_pad[ash]v$/) { # my()
1434             ($local = "", last) if $local eq "local";
1435             $local = "my";
1436         } elsif ($lop->ppaddr ne "pp_undef") { # local()
1437             ($local = "", last) if $local eq "my";
1438             $local = "local";
1439         }
1440     }
1441     $local = "" if $local eq "either"; # no point if it's all undefs
1442     for (; !null($kid); $kid = $kid->sibling) {
1443         if ($local) {
1444             if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") {
1445                 $lop = $kid->first;
1446             } else {
1447                 $lop = $kid;
1448             }
1449             $self->{'avoid_local'}{$$lop}++;
1450             $expr = $self->deparse($kid, 6);
1451             delete $self->{'avoid_local'}{$$lop};
1452         } else {
1453             $expr = $self->deparse($kid, 6);
1454         }
1455         push @exprs, $expr;
1456     }
1457     if ($local) {
1458         return "$local(" . join(", ", @exprs) . ")";
1459     } else {
1460         return $self->maybe_parens( join(", ", @exprs), $cx, 6);        
1461     }
1462 }
1463
1464 sub pp_cond_expr {
1465     my $self = shift;
1466     my($op, $cx) = @_;
1467     my $cond = $op->first;
1468     my $true = $cond->sibling;
1469     my $false = $true->sibling;
1470     my $cuddle = $self->{'cuddle'};
1471     $cond = $self->deparse($cond, 1);
1472     unless ($cx == 0 and is_scope($true) and is_scope($false)) {
1473         $true = $self->deparse($true, 8);
1474         $false = $self->deparse($false, 8);
1475         return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1476     } 
1477     $true = $self->deparse($true, 0);    
1478     if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif
1479         my $head = "if ($cond) {\n\t$true\n\b}";
1480         my @elsifs;
1481         while (!null($false) and $false->ppaddr eq "pp_lineseq") {
1482             my $newop = $false->first->sibling->first;
1483             my $newcond = $newop->first;
1484             my $newtrue = $newcond->sibling;
1485             $false = $newtrue->sibling; # last in chain is OP_AND => no else
1486             $newcond = $self->deparse($newcond, 1);
1487             $newtrue = $self->deparse($newtrue, 0);
1488             push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1489         }
1490         if (!null($false)) {        
1491             $false = $cuddle . "else {\n\t" .
1492               $self->deparse($false, 0) . "\n\b}\cK";
1493         } else {
1494             $false = "\cK";
1495         }
1496         return $head . join($cuddle, "", @elsifs) . $false; 
1497     }
1498     $false = $self->deparse($false, 0);
1499     return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK";
1500 }
1501
1502 sub pp_leaveloop {
1503     my $self = shift;
1504     my($op, $cx) = @_;
1505     my $enter = $op->first;
1506     my $kid = $enter->sibling;
1507     local($self->{'curstash'}) = $self->{'curstash'};
1508     my $head = "";
1509     my $bare = 0;
1510     if ($kid->ppaddr eq "pp_lineseq") { # bare or infinite loop 
1511         if (is_state $kid->last) { # infinite
1512             $head = "for (;;) "; # shorter than while (1)
1513         } else {
1514             $bare = 1;
1515         }
1516     } elsif ($enter->ppaddr eq "pp_enteriter") { # foreach
1517         my $ary = $enter->first->sibling; # first was pushmark
1518         my $var = $ary->sibling;
1519         if ($enter->flags & OPf_STACKED) {
1520             $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1521               $self->deparse($ary->first->sibling->sibling, 9);
1522         } else {
1523             $ary = $self->deparse($ary, 1);
1524         }
1525         if (null $var) {
1526             if ($enter->flags & OPf_SPECIAL) { # thread special var
1527                 $var = $self->pp_threadsv($enter, 1);
1528             } else { # regular my() variable
1529                 $var = $self->pp_padsv($enter, 1);
1530                 if ($self->padname_sv($enter->targ)->IVX ==
1531                     $kid->first->first->sibling->last->cop_seq)
1532                 {
1533                     # If the scope of this variable closes at the last
1534                     # statement of the loop, it must have been
1535                     # declared here.
1536                     $var = "my " . $var;
1537                 }
1538             }
1539         } elsif ($var->ppaddr eq "pp_rv2gv") {
1540             $var = $self->pp_rv2sv($var, 1);
1541         } elsif ($var->ppaddr eq "pp_gv") {
1542             $var = "\$" . $self->deparse($var, 1);
1543         }
1544         $head = "foreach $var ($ary) ";
1545         $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1546     } elsif ($kid->ppaddr eq "pp_null") { # while/until
1547         $kid = $kid->first;
1548         my $name = {"pp_and" => "while", "pp_or" => "until"}
1549                     ->{$kid->ppaddr};
1550         $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
1551         $kid = $kid->first->sibling;
1552     } elsif ($kid->ppaddr eq "pp_stub") { # bare and empty
1553         return "{;}"; # {} could be a hashref
1554     }
1555     # The third-to-last kid is the continue block if the pointer used
1556     # by `next BLOCK' points to its first OP, which happens to be the
1557     # the op_next of the head of the _previous_ statement. 
1558     # Unless it's a bare loop, in which case it's last, since there's
1559     # no unstack or extra nextstate.
1560     my($cont, $precont);
1561     if ($bare) {
1562         $cont = $kid->first;
1563         while (!null($cont->sibling)) {
1564             $precont = $cont;
1565             $cont = $cont->sibling;
1566         }       
1567     } else {
1568         $cont = $kid->first;
1569         while (!null($cont->sibling->sibling->sibling)) {
1570             $precont = $cont;
1571             $cont = $cont->sibling;
1572         }
1573     }
1574 #    cluck $self->{'curcv'}->GV->NAME unless $precont;
1575     if ($precont and $ {$precont->next} == $ {$enter->nextop}) {
1576         my $state = $kid->first;
1577         my $cuddle = $self->{'cuddle'};
1578         my($expr, @exprs);
1579         for (; $$state != $$cont; $state = $state->sibling) {
1580             $expr = "";
1581             if (is_state $state) {
1582                 $expr = $self->deparse($state, 0);
1583                 $state = $state->sibling;
1584                 last if null $kid;
1585             }
1586             $expr .= $self->deparse($state, 0);
1587             push @exprs, $expr if $expr;
1588         }
1589         $kid = join(";\n", @exprs);
1590         $cont = $cuddle . "continue {\n\t" .
1591           $self->deparse($cont, 0) . "\n\b}\cK";
1592     } else {
1593         $cont = "\cK";
1594         $kid = $self->deparse($kid, 0);
1595     }
1596     return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1597 }
1598
1599 sub pp_leavetry {
1600     my $self = shift;
1601     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
1602 }
1603
1604 sub OP_CONST () { 5 }
1605 sub OP_STRINGIFY () { 65 }
1606
1607 sub pp_null {
1608     my $self = shift;
1609     my($op, $cx) = @_;
1610     if (class($op) eq "OP") {
1611         return "'???'" if $op->targ == OP_CONST; # old value is lost
1612     } elsif ($op->first->ppaddr eq "pp_pushmark") {
1613         return $self->pp_list($op, $cx);
1614     } elsif ($op->first->ppaddr eq "pp_enter") {
1615         return $self->pp_leave($op, $cx);
1616     } elsif ($op->targ == OP_STRINGIFY) {
1617         return $self->dquote($op);
1618     } elsif (!null($op->first->sibling) and
1619              $op->first->sibling->ppaddr eq "pp_readline" and
1620              $op->first->sibling->flags & OPf_STACKED) {
1621         return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1622                                    . $self->deparse($op->first->sibling, 7),
1623                                    $cx, 7);
1624     } elsif (!null($op->first->sibling) and
1625              $op->first->sibling->ppaddr eq "pp_trans" and
1626              $op->first->sibling->flags & OPf_STACKED) {
1627         return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1628                                    . $self->deparse($op->first->sibling, 20),
1629                                    $cx, 20);
1630     } else {
1631         return $self->deparse($op->first, $cx);
1632     }
1633 }
1634
1635 sub padname {
1636     my $self = shift;
1637     my $targ = shift;
1638     my $str = $self->padname_sv($targ)->PV;
1639     return padname_fix($str);
1640 }
1641
1642 sub padany {
1643     my $self = shift;
1644     my $op = shift;
1645     return substr($self->padname($op->targ), 1); # skip $/@/%
1646 }
1647
1648 sub pp_padsv {
1649     my $self = shift;
1650     my($op, $cx) = @_;
1651     return $self->maybe_my($op, $cx, $self->padname($op->targ));
1652 }
1653
1654 sub pp_padav { pp_padsv(@_) }
1655 sub pp_padhv { pp_padsv(@_) }
1656
1657 my @threadsv_names;
1658
1659 BEGIN {
1660     @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1661                        "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1662                        "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1663                        "!", "@");
1664 }
1665
1666 sub pp_threadsv {
1667     my $self = shift;
1668     my($op, $cx) = @_;
1669     return $self->maybe_local($op, $cx, "\$" .  $threadsv_names[$op->targ]);
1670 }    
1671
1672 sub pp_gvsv {
1673     my $self = shift;
1674     my($op, $cx) = @_;
1675     return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
1676 }
1677
1678 sub pp_gv {
1679     my $self = shift;
1680     my($op, $cx) = @_;
1681     return $self->gv_name($op->gv);
1682 }
1683
1684 sub pp_aelemfast {
1685     my $self = shift;
1686     my($op, $cx) = @_;
1687     my $gv = $op->gv;
1688     return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1689 }
1690
1691 sub rv2x {
1692     my $self = shift;
1693     my($op, $cx, $type) = @_;
1694     my $kid = $op->first;
1695     my $scope = is_scope($kid);
1696     $kid = $self->deparse($kid, 0);
1697     return $type . ($scope ? "{$kid}" : $kid);
1698 }
1699
1700 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1701 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1702 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1703
1704 # skip rv2av
1705 sub pp_av2arylen {
1706     my $self = shift;
1707     my($op, $cx) = @_;
1708     if ($op->first->ppaddr eq "pp_padav") {
1709         return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
1710     } else {
1711         return $self->maybe_local($op, $cx, $self->rv2x($op->first, '$#'));
1712     }
1713 }
1714
1715 # skip down to the old, ex-rv2cv
1716 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
1717
1718 sub pp_rv2av {
1719     my $self = shift;
1720     my($op, $cx) = @_;
1721     my $kid = $op->first;
1722     if ($kid->ppaddr eq "pp_const") { # constant list
1723         my $av = $kid->sv;
1724         return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1725     } else {
1726         return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
1727     }
1728  }
1729
1730
1731 sub elem {
1732     my $self = shift;
1733     my ($op, $cx, $left, $right, $padname) = @_;
1734     my($array, $idx) = ($op->first, $op->first->sibling);
1735     unless ($array->ppaddr eq $padname) { # Maybe this has been fixed   
1736         $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1737     }
1738     if ($array->ppaddr eq $padname) {
1739         $array = $self->padany($array);
1740     } elsif (is_scope($array)) { # ${expr}[0]
1741         $array = "{" . $self->deparse($array, 0) . "}";
1742     } elsif (is_scalar $array) { # $x[0], $$x[0], ...
1743         $array = $self->deparse($array, 24);
1744     } else {
1745         # $x[20][3]{hi} or expr->[20]
1746         my $arrow;
1747         $arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/;
1748         return $self->deparse($array, 24) . $arrow .
1749             $left . $self->deparse($idx, 1) . $right;
1750     }
1751     $idx = $self->deparse($idx, 1);
1752     return "\$" . $array . $left . $idx . $right;
1753 }
1754
1755 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) }
1756 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) }
1757
1758 sub pp_gelem {
1759     my $self = shift;
1760     my($op, $cx) = @_;
1761     my($glob, $part) = ($op->first, $op->last);
1762     $glob = $glob->first; # skip rv2gv
1763     $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug
1764     my $scope = is_scope($glob);
1765     $glob = $self->deparse($glob, 0);
1766     $part = $self->deparse($part, 1);
1767     return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
1768 }
1769
1770 sub slice {
1771     my $self = shift;
1772     my ($op, $cx, $left, $right, $regname, $padname) = @_;
1773     my $last;
1774     my(@elems, $kid, $array, $list);
1775     if (class($op) eq "LISTOP") {
1776         $last = $op->last;
1777     } else { # ex-hslice inside delete()
1778         for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
1779         $last = $kid;
1780     }
1781     $array = $last;
1782     $array = $array->first
1783         if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null";
1784     if (is_scope($array)) {
1785         $array = "{" . $self->deparse($array, 0) . "}";
1786     } elsif ($array->ppaddr eq $padname) {
1787         $array = $self->padany($array);
1788     } else {
1789         $array = $self->deparse($array, 24);
1790     }
1791     $kid = $op->first->sibling; # skip pushmark
1792     if ($kid->ppaddr eq "pp_list") {
1793         $kid = $kid->first->sibling; # skip list, pushmark
1794         for (; !null $kid; $kid = $kid->sibling) {
1795             push @elems, $self->deparse($kid, 6);
1796         }
1797         $list = join(", ", @elems);
1798     } else {
1799         $list = $self->deparse($kid, 1);
1800     }
1801     return "\@" . $array . $left . $list . $right;
1802 }
1803
1804 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", 
1805                                       "pp_rv2av", "pp_padav")) }
1806 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}",
1807                                       "pp_rv2hv", "pp_padhv")) }
1808
1809 sub pp_lslice {
1810     my $self = shift;
1811     my($op, $cx) = @_;
1812     my $idx = $op->first;
1813     my $list = $op->last;
1814     my(@elems, $kid);
1815     $list = $self->deparse($list, 1);
1816     $idx = $self->deparse($idx, 1);
1817     return "($list)" . "[$idx]";
1818 }
1819
1820 sub OPpENTERSUB_AMPER () { 8 }
1821
1822 sub OPf_WANT () { 3 }
1823 sub OPf_WANT_VOID () { 1 }
1824 sub OPf_WANT_SCALAR () { 2 }
1825 sub OPf_WANT_LIST () { 2 }
1826
1827 sub want_scalar {
1828     my $op = shift;
1829     return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
1830 }
1831
1832 sub pp_entersub {
1833     my $self = shift;
1834     my($op, $cx) = @_;
1835     my $prefix = "";
1836     my $amper = "";
1837     my $proto = undef;
1838     my $simple = 0;
1839     my($kid, $args, @exprs);
1840     if (not null $op->first->sibling) { # method
1841         $kid = $op->first->sibling; # skip pushmark
1842         my $obj = $self->deparse($kid, 24);
1843         $kid = $kid->sibling;
1844         for (; not null $kid->sibling; $kid = $kid->sibling) {
1845             push @exprs, $self->deparse($kid, 6);
1846         }
1847         my $meth = $kid->first;
1848         if ($meth->ppaddr eq "pp_const") {
1849             $meth = $meth->sv->PV; # needs to be bare
1850         } else {
1851             $meth = $self->deparse($meth, 1);
1852         }
1853         $args = join(", ", @exprs);     
1854         $kid = $obj . "->" . $meth;
1855         if ($args) {
1856             return $kid . "(" . $args . ")"; # parens mandatory
1857         } else {
1858             return $kid; # toke.c fakes parens
1859         }
1860     }
1861     # else, not a method
1862     if ($op->flags & OPf_SPECIAL) {
1863         $prefix = "do ";
1864     } elsif ($op->private & OPpENTERSUB_AMPER) {
1865         $amper = "&";
1866     }
1867     $kid = $op->first;
1868     $kid = $kid->first->sibling; # skip ex-list, pushmark
1869     for (; not null $kid->sibling; $kid = $kid->sibling) {
1870         push @exprs, $kid;
1871     }
1872     if (is_scope($kid)) {
1873         $amper = "&";
1874         $kid = "{" . $self->deparse($kid, 0) . "}";
1875     } elsif ($kid->first->ppaddr eq "pp_gv") {
1876         my $gv = $kid->first->gv;
1877         if (class($gv->CV) ne "SPECIAL") {
1878             $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
1879         }
1880         $simple = 1;
1881         $kid = $self->deparse($kid, 24);
1882     } elsif (is_scalar $kid->first) {
1883         $amper = "&";
1884         $kid = $self->deparse($kid, 24);
1885     } else {
1886         $prefix = "";
1887         $kid = $self->deparse($kid, 24) . "->";
1888     }
1889     if (defined $proto and not $amper) {
1890         my($arg, $real);
1891         my $doneok = 0;
1892         my @args = @exprs;
1893         my @reals;
1894         $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
1895         while ($proto) {
1896             $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
1897             my $chr = $1;
1898             if ($chr eq "") {
1899                 undef $proto if @args;
1900             } elsif ($chr eq ";") {
1901                 $doneok = 1;
1902             } elsif ($chr eq "@" or $chr eq "%") {
1903                 push @reals, map($self->deparse($_, 6), @args);
1904                 @args = ();
1905             } else {
1906                 $arg = shift @args;
1907                 undef $proto, last unless $arg;
1908                 if ($chr eq "\$") {
1909                     if (want_scalar $arg) {
1910                         push @reals, $self->deparse($arg, 6);
1911                     } else {
1912                         undef $proto;
1913                     }
1914                 } elsif ($chr eq "&") {
1915                     if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) {
1916                         push @reals, $self->deparse($arg, 6);
1917                     } else {
1918                         undef $proto;
1919                     }
1920                 } elsif ($chr eq "*") {
1921                     if ($arg->ppaddr =~ /^pp_s?refgen$/
1922                         and $arg->first->first->ppaddr eq "pp_rv2gv")
1923                     {
1924                         $real = $arg->first->first; # skip refgen, null
1925                         if ($real->first->ppaddr eq "pp_gv") {
1926                             push @reals, $self->deparse($real, 6);
1927                         } else {
1928                             push @reals, $self->deparse($real->first, 6);
1929                         }
1930                     } else {
1931                         undef $proto;
1932                     }
1933                 } elsif (substr($chr, 0, 1) eq "\\") {
1934                     $chr = substr($chr, 1);
1935                     if ($arg->ppaddr =~ /^pp_s?refgen$/ and
1936                         !null($real = $arg->first) and
1937                         ($chr eq "\$" && is_scalar($real->first)
1938                          or ($chr eq "\@"
1939                              && $real->first->sibling->ppaddr 
1940                              =~ /^pp_(rv2|pad)av$/)
1941                          or ($chr eq "%"
1942                              && $real->first->sibling->ppaddr
1943                              =~ /^pp_(rv2|pad)hv$/)
1944                          #or ($chr eq "&" # This doesn't work
1945                          #   && $real->first->ppaddr eq "pp_rv2cv")
1946                          or ($chr eq "*"
1947                              && $real->first->ppaddr eq "pp_rv2gv")))
1948                     {
1949                         push @reals, $self->deparse($real, 6);
1950                     } else {
1951                         undef $proto;
1952                     }
1953                 }
1954             }
1955         }
1956         undef $proto if $proto and !$doneok;
1957         undef $proto if @args;
1958         $args = join(", ", @reals);
1959         $amper = "";
1960         unless (defined $proto) {
1961             $amper = "&";
1962             $args = join(", ", map($self->deparse($_, 6), @exprs));
1963         }
1964     } else {
1965         $args = join(", ", map($self->deparse($_, 6), @exprs));
1966     }
1967     if ($prefix or $amper) {
1968         if ($op->flags & OPf_STACKED) {
1969             return $prefix . $amper . $kid . "(" . $args . ")";
1970         } else {
1971             return $prefix . $amper. $kid;
1972         }
1973     } else {
1974         if (defined $proto and $proto eq "") {
1975             return $kid;
1976         } elsif ($proto eq "\$") {
1977             return $self->maybe_parens_func($kid, $args, $cx, 16);
1978         } elsif ($proto or $simple) {
1979             return $self->maybe_parens_func($kid, $args, $cx, 5);
1980         } else {
1981             return "$kid(" . $args . ")";
1982         }
1983     }
1984 }
1985
1986 sub pp_enterwrite { unop(@_, "write") }
1987
1988 # escape things that cause interpolation in double quotes,
1989 # but not character escapes
1990 sub uninterp {
1991     my($str) = @_;
1992     $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
1993     return $str;
1994 }
1995
1996 # the same, but treat $|, $), and $ at the end of the string differently
1997 sub re_uninterp {
1998     my($str) = @_;
1999     $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2000     $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2001     return $str;
2002 }
2003
2004 # character escapes, but not delimiters that might need to be escaped
2005 sub escape_str { # ASCII
2006     my($str) = @_;
2007     $str =~ s/\a/\\a/g;
2008 #    $str =~ s/\cH/\\b/g; # \b means someting different in a regex 
2009     $str =~ s/\t/\\t/g;
2010     $str =~ s/\n/\\n/g;
2011     $str =~ s/\e/\\e/g;
2012     $str =~ s/\f/\\f/g;
2013     $str =~ s/\r/\\r/g;
2014     $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2015     $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2016     return $str;
2017 }
2018
2019 # Don't do this for regexen
2020 sub unback {
2021     my($str) = @_;
2022     $str =~ s/\\/\\\\/g;
2023     return $str;
2024 }
2025
2026 sub balanced_delim {
2027     my($str) = @_;
2028     my @str = split //, $str;
2029     my($ar, $open, $close, $fail, $c, $cnt);
2030     for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2031         ($open, $close) = @$ar;
2032         $fail = 0; $cnt = 0;
2033         for $c (@str) {
2034             if ($c eq $open) {
2035                 $cnt++;
2036             } elsif ($c eq $close) {
2037                 $cnt--;
2038                 if ($cnt < 0) {
2039                     $fail = 1;
2040                     last;
2041                 }
2042             }
2043         }
2044         $fail = 1 if $cnt != 0;
2045         return ($open, "$open$str$close") if not $fail;
2046     }
2047     return ("", $str);
2048 }
2049
2050 sub single_delim {
2051     my($q, $default, $str) = @_;
2052     return "$default$str$default" if index($str, $default) == -1;
2053     my($succeed, $delim);
2054     ($succeed, $str) = balanced_delim($str);
2055     return "$q$str" if $succeed;
2056     for $delim ('/', '"', '#') {
2057         return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2058     }
2059     $str =~ s/$default/\\$default/g;
2060     return "$default$str$default";
2061 }
2062
2063 sub SVf_IOK () {0x10000}
2064 sub SVf_NOK () {0x20000}
2065 sub SVf_ROK () {0x80000}
2066
2067 sub const {
2068     my $sv = shift;
2069     if (class($sv) eq "SPECIAL") {
2070         return ('undef', '1', '0')[$$sv-1];
2071     } elsif ($sv->FLAGS & SVf_IOK) {
2072         return $sv->IV;
2073     } elsif ($sv->FLAGS & SVf_NOK) {
2074         return $sv->NV;
2075     } elsif ($sv->FLAGS & SVf_ROK) {
2076         return "\\(" . const($sv->RV) . ")"; # constant folded
2077     } else {
2078         my $str = $sv->PV;
2079         if ($str =~ /[^ -~]/) { # ASCII
2080             return single_delim("qq", '"', uninterp escape_str unback $str);
2081         } else {
2082             $str =~ s/\\/\\\\/g;
2083             return single_delim("q", "'", $str);
2084         }
2085     }
2086 }
2087
2088 sub pp_const {
2089     my $self = shift;
2090     my($op, $cx) = @_;
2091 #    if ($op->private & OPp_CONST_BARE) { # trouble with `=>' autoquoting 
2092 #       return $op->sv->PV;
2093 #    }
2094     return const($op->sv);
2095 }
2096
2097 sub dq {
2098     my $self = shift;
2099     my $op = shift;
2100     my $type = $op->ppaddr;
2101     if ($type eq "pp_const") {
2102         return uninterp(escape_str(unback($op->sv->PV)));
2103     } elsif ($type eq "pp_concat") {
2104         return $self->dq($op->first) . $self->dq($op->last);
2105     } elsif ($type eq "pp_uc") {
2106         return '\U' . $self->dq($op->first->sibling) . '\E';
2107     } elsif ($type eq "pp_lc") {
2108         return '\L' . $self->dq($op->first->sibling) . '\E';
2109     } elsif ($type eq "pp_ucfirst") {
2110         return '\u' . $self->dq($op->first->sibling);
2111     } elsif ($type eq "pp_lcfirst") {
2112         return '\l' . $self->dq($op->first->sibling);
2113     } elsif ($type eq "pp_quotemeta") {
2114         return '\Q' . $self->dq($op->first->sibling) . '\E';
2115     } elsif ($type eq "pp_join") {
2116         return $self->deparse($op->last, 26); # was join($", @ary)
2117     } else {
2118         return $self->deparse($op, 26);
2119     }
2120 }
2121
2122 sub pp_backtick {
2123     my $self = shift;
2124     my($op, $cx) = @_;
2125     # skip pushmark
2126     return single_delim("qx", '`', $self->dq($op->first->sibling));
2127 }
2128
2129 sub dquote {
2130     my $self = shift;
2131     my $op = shift;
2132     # skip ex-stringify, pushmark
2133     return single_delim("qq", '"', $self->dq($op->first->sibling)); 
2134 }
2135
2136 # OP_STRINGIFY is a listop, but it only ever has one arg (?)
2137 sub pp_stringify { dquote(@_) }
2138
2139 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2140 # note that tr(from)/to/ is OK, but not tr/from/(to)
2141 sub double_delim {
2142     my($from, $to) = @_;
2143     my($succeed, $delim);
2144     if ($from !~ m[/] and $to !~ m[/]) {
2145         return "/$from/$to/";
2146     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2147         if (($succeed, $to) = balanced_delim($to) and $succeed) {
2148             return "$from$to";
2149         } else {
2150             for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2151                 return "$from$delim$to$delim" if index($to, $delim) == -1;
2152             }
2153             $to =~ s[/][\\/]g;
2154             return "$from/$to/";
2155         }
2156     } else {
2157         for $delim ('/', '"', '#') { # note no '
2158             return "$delim$from$delim$to$delim"
2159                 if index($to . $from, $delim) == -1;
2160         }
2161         $from =~ s[/][\\/]g;
2162         $to =~ s[/][\\/]g;
2163         return "/$from/$to/";   
2164     }
2165 }
2166
2167 sub pchr { # ASCII
2168     my($n) = @_;
2169     if ($n == ord '\\') {
2170         return '\\\\';
2171     } elsif ($n >= ord(' ') and $n <= ord('~')) {
2172         return chr($n);
2173     } elsif ($n == ord "\a") {
2174         return '\\a';
2175     } elsif ($n == ord "\b") {
2176         return '\\b';
2177     } elsif ($n == ord "\t") {
2178         return '\\t';
2179     } elsif ($n == ord "\n") {
2180         return '\\n';
2181     } elsif ($n == ord "\e") {
2182         return '\\e';
2183     } elsif ($n == ord "\f") {
2184         return '\\f';
2185     } elsif ($n == ord "\r") {
2186         return '\\r';
2187     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2188         return '\\c' . chr(ord("@") + $n);
2189     } else {
2190 #       return '\x' . sprintf("%02x", $n);
2191         return '\\' . sprintf("%03o", $n);
2192     }
2193 }
2194
2195 sub collapse {
2196     my(@chars) = @_;
2197     my($c, $str, $tr);
2198     for ($c = 0; $c < @chars; $c++) {
2199         $tr = $chars[$c];
2200         $str .= pchr($tr);
2201         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2202             $chars[$c + 2] == $tr + 2)
2203         {
2204             for (; $c <= $#chars and $chars[$c + 1] == $chars[$c] + 1; $c++) {}
2205             $str .= "-";
2206             $str .= pchr($chars[$c]);
2207         }
2208     }
2209     return $str;
2210 }
2211
2212 sub OPpTRANS_SQUASH () { 16 }
2213 sub OPpTRANS_DELETE () { 32 }
2214 sub OPpTRANS_COMPLEMENT () { 64 }
2215
2216 sub pp_trans {
2217     my $self = shift;
2218     my($op, $cx) = @_;
2219     my(@table) = unpack("s256", $op->pv);
2220     my($c, $tr, @from, @to, @delfrom, $delhyphen);
2221     if ($table[ord "-"] != -1 and 
2222         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2223     {
2224         $tr = $table[ord "-"];
2225         $table[ord "-"] = -1;
2226         if ($tr >= 0) {
2227             @from = ord("-");
2228             @to = $tr;
2229         } else { # -2 ==> delete
2230             $delhyphen = 1;
2231         }
2232     }
2233     for ($c = 0; $c < 256; $c++) {
2234         $tr = $table[$c];
2235         if ($tr >= 0) {
2236             push @from, $c; push @to, $tr;
2237         } elsif ($tr == -2) {
2238             push @delfrom, $c;
2239         }
2240     }
2241     my $flags;
2242     @from = (@from, @delfrom);
2243     if ($op->private & OPpTRANS_COMPLEMENT) {
2244         $flags .= "c";
2245         my @newfrom = ();
2246         my %from;
2247         @from{@from} = (1) x @from;
2248         for ($c = 0; $c < 256; $c++) {
2249             push @newfrom, $c unless $from{$c};
2250         }
2251         @from = @newfrom;
2252     }
2253     if ($op->private & OPpTRANS_DELETE) {
2254         $flags .= "d";
2255     } else {
2256         pop @to while $#to and $to[$#to] == $to[$#to -1];
2257     }
2258     $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2259     my($from, $to);
2260     $from = collapse(@from);
2261     $to = collapse(@to);
2262     $from .= "-" if $delhyphen;
2263     return "tr" . double_delim($from, $to) . $flags;
2264 }
2265
2266 # Like dq(), but different
2267 sub re_dq {
2268     my $self = shift;
2269     my $op = shift;
2270     my $type = $op->ppaddr;
2271     if ($type eq "pp_const") {
2272         return uninterp($op->sv->PV);
2273     } elsif ($type eq "pp_concat") {
2274         return $self->re_dq($op->first) . $self->re_dq($op->last);
2275     } elsif ($type eq "pp_uc") {
2276         return '\U' . $self->re_dq($op->first->sibling) . '\E';
2277     } elsif ($type eq "pp_lc") {
2278         return '\L' . $self->re_dq($op->first->sibling) . '\E';
2279     } elsif ($type eq "pp_ucfirst") {
2280         return '\u' . $self->re_dq($op->first->sibling);
2281     } elsif ($type eq "pp_lcfirst") {
2282         return '\l' . $self->re_dq($op->first->sibling);
2283     } elsif ($type eq "pp_quotemeta") {
2284         return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2285     } elsif ($type eq "pp_join") {
2286         return $self->deparse($op->last, 26); # was join($", @ary)
2287     } else {
2288         return $self->deparse($op, 26);
2289     }
2290 }
2291
2292 sub pp_regcomp {
2293     my $self = shift;
2294     my($op, $cx) = @_;
2295     my $kid = $op->first;
2296     $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe";
2297     return $self->re_dq($kid);
2298 }
2299
2300 sub OPp_RUNTIME () { 64 }
2301
2302 sub PMf_ONCE () { 0x2 }
2303 sub PMf_SKIPWHITE () { 0x10 }
2304 sub PMf_FOLD () { 0x20 }
2305 sub PMf_CONST () { 0x40 }
2306 sub PMf_KEEP () { 0x80 }
2307 sub PMf_GLOBAL () { 0x100 }
2308 sub PMf_CONTINUE () { 0x200 }
2309 sub PMf_EVAL () { 0x400 }
2310 sub PMf_MULTILINE () { 0x1000 }
2311 sub PMf_SINGLELINE () { 0x2000 }
2312 sub PMf_LOCALE () { 0x4000 }
2313 sub PMf_EXTENDED () { 0x8000 }
2314
2315 # osmic acid -- see osmium tetroxide
2316
2317 my %matchwords;
2318 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2319     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic', 
2320     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi'); 
2321
2322 sub pp_match {
2323     my $self = shift;
2324     my($op, $cx) = @_;
2325     my $kid = $op->first;
2326     my ($binop, $var, $re) = ("", "", "");
2327     if ($op->flags & OPf_STACKED) {
2328         $binop = 1;
2329         $var = $self->deparse($kid, 20);
2330         $kid = $kid->sibling;
2331     }
2332     if (null $kid) {
2333         $re = re_uninterp(escape_str($op->precomp));
2334     } else {
2335         $re = $self->deparse($kid, 1);
2336     }
2337     my $flags = "";
2338     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2339     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2340     $flags .= "i" if $op->pmflags & PMf_FOLD;
2341     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2342     $flags .= "o" if $op->pmflags & PMf_KEEP;
2343     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2344     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2345     $flags = $matchwords{$flags} if $matchwords{$flags};
2346     if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2347         $re =~ s/\?/\\?/g;
2348         $re = "?$re?";
2349     } else {
2350         $re = single_delim("m", "/", $re);
2351     }
2352     $re = $re . $flags;
2353     if ($binop) {
2354         return $self->maybe_parens("$var =~ $re", $cx, 20);
2355     } else {
2356         return $re;
2357     }
2358 }
2359
2360 sub pp_pushre { pp_match(@_) }
2361
2362 sub pp_split {
2363     my $self = shift;
2364     my($op, $cx) = @_;
2365     my($kid, @exprs, $ary, $expr);
2366     $kid = $op->first;
2367     if ($ {$kid->pmreplroot}) {
2368         $ary = '@' . $self->gv_name($kid->pmreplroot);
2369     }
2370     for (; !null($kid); $kid = $kid->sibling) {
2371         push @exprs, $self->deparse($kid, 6);
2372     }
2373     $expr = "split(" . join(", ", @exprs) . ")";
2374     if ($ary) {
2375         return $self->maybe_parens("$ary = $expr", $cx, 7);
2376     } else {
2377         return $expr;
2378     }
2379 }
2380
2381 # oxime -- any of various compounds obtained chiefly by the action of
2382 # hydroxylamine on aldehydes and ketones and characterized by the
2383 # bivalent grouping C=NOH [Webster's Tenth]
2384
2385 my %substwords;
2386 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2387     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2388     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2389     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2390
2391 sub pp_subst {
2392     my $self = shift;
2393     my($op, $cx) = @_;
2394     my $kid = $op->first;
2395     my($binop, $var, $re, $repl) = ("", "", "", "");
2396     if ($op->flags & OPf_STACKED) {
2397         $binop = 1;
2398         $var = $self->deparse($kid, 20);
2399         $kid = $kid->sibling;
2400     }
2401     my $flags = "";    
2402     if (null($op->pmreplroot)) {
2403         $repl = $self->dq($kid);
2404         $kid = $kid->sibling;
2405     } else {
2406         $repl = $op->pmreplroot->first; # skip substcont
2407         while ($repl->ppaddr eq "pp_entereval") {
2408             $repl = $repl->first;
2409             $flags .= "e";
2410         }
2411         $repl = $self->dq($repl);
2412     }
2413     if (null $kid) {
2414         $re = re_uninterp(escape_str($op->precomp));
2415     } else {
2416         $re = $self->deparse($kid, 1);
2417     }
2418     $flags .= "e" if $op->pmflags & PMf_EVAL;
2419     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2420     $flags .= "i" if $op->pmflags & PMf_FOLD;
2421     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2422     $flags .= "o" if $op->pmflags & PMf_KEEP;
2423     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2424     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2425     $flags = $substwords{$flags} if $substwords{$flags};
2426     if ($binop) {
2427         return $self->maybe_parens("$var =~ s"
2428                                    . double_delim($re, $repl) . $flags,
2429                                    $cx, 20);
2430     } else {
2431         return "s". double_delim($re, $repl) . $flags;  
2432     }
2433 }
2434
2435 1;
2436 __END__
2437
2438 =head1 NAME
2439
2440 B::Deparse - Perl compiler backend to produce perl code
2441
2442 =head1 SYNOPSIS
2443
2444 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-s>I<LETTERS>] I<prog.pl>
2445
2446 =head1 DESCRIPTION
2447
2448 B::Deparse is a backend module for the Perl compiler that generates
2449 perl source code, based on the internal compiled structure that perl
2450 itself creates after parsing a program. The output of B::Deparse won't
2451 be exactly the same as the original source, since perl doesn't keep
2452 track of comments or whitespace, and there isn't a one-to-one
2453 correspondence between perl's syntactical constructions and their
2454 compiled form, but it will often be close. When you use the B<-p>
2455 option, the output also includes parentheses even when they are not
2456 required by precedence, which can make it easy to see if perl is
2457 parsing your expressions the way you intended.
2458
2459 Please note that this module is mainly new and untested code and is
2460 still under development, so it may change in the future.
2461
2462 =head1 OPTIONS
2463
2464 As with all compiler backend options, these must follow directly after
2465 the '-MO=Deparse', separated by a comma but not any white space.
2466
2467 =over 4
2468
2469 =item B<-p>
2470
2471 Print extra parentheses. Without this option, B::Deparse includes
2472 parentheses in its output only when they are needed, based on the
2473 structure of your program. With B<-p>, it uses parentheses (almost)
2474 whenever they would be legal. This can be useful if you are used to
2475 LISP, or if you want to see how perl parses your input. If you say
2476
2477     if ($var & 0x7f == 65) {print "Gimme an A!"} 
2478     print ($which ? $a : $b), "\n";
2479     $name = $ENV{USER} or "Bob";
2480
2481 C<B::Deparse,-p> will print
2482
2483     if (($var & 0)) {
2484         print('Gimme an A!')
2485     };
2486     (print(($which ? $a : $b)), '???');
2487     (($name = $ENV{'USER'}) or '???')
2488
2489 which probably isn't what you intended (the C<'???'> is a sign that
2490 perl optimized away a constant value).
2491
2492 =item B<-u>I<PACKAGE>
2493
2494 Normally, B::Deparse deparses the main code of a program, all the subs
2495 called by the main program (and all the subs called by them,
2496 recursively), and any other subs in the main:: package. To include
2497 subs in other packages that aren't called directly, such as AUTOLOAD,
2498 DESTROY, other subs called automatically by perl, and methods, which
2499 aren't resolved to subs until runtime, use the B<-u> option. The
2500 argument to B<-u> is the name of a package, and should follow directly
2501 after the 'u'. Multiple B<-u> options may be given, separated by
2502 commas.  Note that unlike some other backends, B::Deparse doesn't
2503 (yet) try to guess automatically when B<-u> is needed -- you must
2504 invoke it yourself.
2505
2506 =item B<-s>I<LETTERS>
2507
2508 Tweak the style of B::Deparse's output. At the moment, only one style
2509 option is implemented:
2510
2511 =over 4
2512
2513 =item B<C>
2514
2515 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2516
2517     if (...) {
2518          ...
2519     } else {
2520          ...
2521     }
2522
2523 instead of
2524
2525     if (...) {
2526          ...
2527     }
2528     else {
2529          ...
2530     }
2531
2532 The default is not to cuddle.
2533
2534 =back
2535
2536 =back
2537
2538 =head1 BUGS
2539
2540 See the 'to do' list at the beginning of the module file.
2541
2542 =head1 AUTHOR
2543
2544 Stephen McCamant <alias@mcs.com>, based on an earlier version by
2545 Malcolm Beattie <mbeattie@sable.ox.ac.uk>.
2546
2547 =cut