ext/B/B/Deparse.pm

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