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