ext/B/B/Deparse.pm

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