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