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