ext/B/B/Deparse.pm

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