lib/perl5/5.6.1/msys/B/Deparse.pm

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