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