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