ext/B/B/Deparse.pm

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