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