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