ext/B/B/Deparse.pm

   1 # B::Deparse.pm
   2 # Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved.
   3 # This module is free software; you can redistribute and/or modify
   4 # it under the same terms as Perl itself.
   5
   6 # This is based on the module of the same name by Malcolm Beattie,
   7 # but essentially none of his code remains.
   8
   9 package B::Deparse;
  10 use Carp 'cluck', 'croak';
  11 use B qw(class main_root main_start main_cv svref_2object opnumber
  12          OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
  13          OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
  14          OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
  15          OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
  16          SVf_IOK SVf_NOK SVf_ROK SVf_POK
  17          CVf_METHOD CVf_LOCKED CVf_LVALUE
  18          PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
  19          PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
  20 $VERSION = 0.60;
  21 use strict;
  22
  23 # Changes between 0.50 and 0.51:
  24 # - fixed nulled leave with live enter in sort { }
  25 # - fixed reference constants (\"str")
  26 # - handle empty programs gracefully
  27 # - handle infinte loops (for (;;) {}, while (1) {})
  28 # - differentiate between `for my $x ...' and `my $x; for $x ...'
  29 # - various minor cleanups
  30 # - moved globals into an object
  31 # - added `-u', like B::C
  32 # - package declarations using cop_stash
  33 # - subs, formats and code sorted by cop_seq
  34 # Changes between 0.51 and 0.52:
  35 # - added pp_threadsv (special variables under USE_THREADS)
  36 # - added documentation
  37 # Changes between 0.52 and 0.53:
  38 # - many changes adding precedence contexts and associativity
  39 # - added `-p' and `-s' output style options
  40 # - various other minor fixes
  41 # Changes between 0.53 and 0.54:
  42 # - added support for new `for (1..100)' optimization,
  43 #   thanks to Gisle Aas
  44 # Changes between 0.54 and 0.55:
  45 # - added support for new qr// construct
  46 # - added support for new pp_regcreset OP
  47 # Changes between 0.55 and 0.56:
  48 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
  49 # - fixed $# on non-lexicals broken in last big rewrite
  50 # - added temporary fix for change in opcode of OP_STRINGIFY
  51 # - fixed problem in 0.54's for() patch in `for (@ary)'
  52 # - fixed precedence in conditional of ?:
  53 # - tweaked list paren elimination in `my($x) = @_'
  54 # - made continue-block detection trickier wrt. null ops
  55 # - fixed various prototype problems in pp_entersub
  56 # - added support for sub prototypes that never get GVs
  57 # - added unquoting for special filehandle first arg in truncate
  58 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
  59 # - added semicolons at the ends of blocks
  60 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
  61 # Changes between 0.56 and 0.561:
  62 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
  63 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
  64 # Changes between 0.561 and 0.57:
  65 # - stylistic changes to symbolic constant stuff
  66 # - handled scope in s///e replacement code
  67 # - added unquote option for expanding "" into concats, etc.
  68 # - split method and proto parts of pp_entersub into separate functions
  69 # - various minor cleanups
  70 # Changes after 0.57:
  71 # - added parens in \&foo (patch by Albert Dvornik)
  72 # Changes between 0.57 and 0.58:
  73 # - fixed `0' statements that weren't being printed
  74 # - added methods for use from other programs
  75 #   (based on patches from James Duncan and Hugo van der Sanden)
  76 # - added -si and -sT to control indenting (also based on a patch from Hugo)
  77 # - added -sv to print something else instead of '???'
  78 # - preliminary version of utf8 tr/// handling
  79 # Changes after 0.58:
  80 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
  81 # - added support for Hugo's new OP_SETSTATE (like nextstate)
  82 # Changes between 0.58 and 0.59
  83 # - added support for Chip's OP_METHOD_NAMED
  84 # - added support for Ilya's OPpTARGET_MY optimization
  85 # - elided arrows before `()' subscripts when possible
  86 # Changes between 0.59 and 0.60
  87 # - support for method attribues was added
  88 # - some warnings fixed
  89 # - separate recognition of constant subs
  90 # - rewrote continue block handling, now recoginizing for loops
  91 # - added more control of expanding control structures
  92
  93 # Todo:
  94 # - finish tr/// changes
  95 # - add option for even more parens (generalize \&foo change)
  96 # - {} around variables in strings ("${var}letters")
  97 #   base/lex.t 25-27
  98 #   comp/term.t 11
  99 # - left/right context
 100 # - recognize `use utf8', `use integer', etc
 101 # - treat top-level block specially for incremental output
 102 # - interpret high bit chars in string as utf8 \x{...} (when?)
 103 # - copy comments (look at real text with $^P?)
 104 # - avoid semis in one-statement blocks
 105 # - associativity of &&=, ||=, ?:
 106 # - ',' => '=>' (auto-unquote?)
 107 # - break long lines ("\r" as discretionary break?)
 108 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
 109 # - more style options: brace style, hex vs. octal, quotes, ...
 110 # - print big ints as hex/octal instead of decimal (heuristic?)
 111 # - handle `my $x if 0'?
 112 # - include values of variables (e.g. set in BEGIN)
 113 # - coordinate with Data::Dumper (both directions? see previous)
 114 # - version using op_next instead of op_first/sibling?
 115 # - avoid string copies (pass arrays, one big join?)
 116 # - auto-apply `-u'?
 117 # - -uPackage:: descend recursively?
 118 # - here-docs?
 119 # - <DATA>?
 120
 121 # Tests that will always fail:
 122 # comp/redef.t -- all (redefinition happens at compile time)
 123
 124 # Object fields (were globals):
 125 #
 126 # avoid_local:
 127 # (local($a), local($b)) and local($a, $b) have the same internal
 128 # representation but the short form looks better. We notice we can
 129 # use a large-scale local when checking the list, but need to prevent
 130 # individual locals too. This hash holds the addresses of OPs that
 131 # have already had their local-ness accounted for. The same thing
 132 # is done with my().
 133 #
 134 # curcv:
 135 # CV for current sub (or main program) being deparsed
 136 #
 137 # curstash:
 138 # name of the current package for deparsed code
 139 #
 140 # subs_todo:
 141 # array of [cop_seq, GV, is_format?] for subs and formats we still
 142 # want to deparse
 143 #
 144 # protos_todo:
 145 # as above, but [name, prototype] for subs that never got a GV
 146 #
 147 # subs_done, forms_done:
 148 # keys are addresses of GVs for subs and formats we've already
 149 # deparsed (or at least put into subs_todo)
 150 #
 151 # parens: -p
 152 # linenums: -l
 153 # unquote: -q
 154 # cuddle: ` ' or `\n', depending on -sC
 155 # indent_size: -si
 156 # use_tabs: -sT
 157 # ex_const: -sv
 158
 159 # A little explanation of how precedence contexts and associativity
 160 # work:
 161 #
 162 # deparse() calls each per-op subroutine with an argument $cx (short
 163 # for context, but not the same as the cx* in the perl core), which is
 164 # a number describing the op's parents in terms of precedence, whether
 165 # they're inside an expression or at statement level, etc.  (see
 166 # chart below). When ops with children call deparse on them, they pass
 167 # along their precedence. Fractional values are used to implement
 168 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
 169 # parentheses hacks. The major disadvantage of this scheme is that
 170 # it doesn't know about right sides and left sides, so say if you
 171 # assign a listop to a variable, it can't tell it's allowed to leave
 172 # the parens off the listop.
 173
 174 # Precedences:
 175 # 26             [TODO] inside interpolation context ("")
 176 # 25 left        terms and list operators (leftward)
 177 # 24 left        ->
 178 # 23 nonassoc    ++ --
 179 # 22 right       **
 180 # 21 right       ! ~ \ and unary + and -
 181 # 20 left        =~ !~
 182 # 19 left        * / % x
 183 # 18 left        + - .
 184 # 17 left        << >>
 185 # 16 nonassoc    named unary operators
 186 # 15 nonassoc    < > <= >= lt gt le ge
 187 # 14 nonassoc    == != <=> eq ne cmp
 188 # 13 left        &
 189 # 12 left        | ^
 190 # 11 left        &&
 191 # 10 left        ||
 192 #  9 nonassoc    ..  ...
 193 #  8 right       ?:
 194 #  7 right       = += -= *= etc.
 195 #  6 left        , =>
 196 #  5 nonassoc    list operators (rightward)
 197 #  4 right       not
 198 #  3 left        and
 199 #  2 left        or xor
 200 #  1             statement modifiers
 201 #  0             statement level
 202
 203 # Nonprinting characters with special meaning:
 204 # \cS - steal parens (see maybe_parens_unop)
 205 # \n - newline and indent
 206 # \t - increase indent
 207 # \b - decrease indent (`outdent')
 208 # \f - flush left (no indent)
 209 # \cK - kill following semicolon, if any
 210
 211 sub null {
 212     my $op = shift;
 213     return class($op) eq "NULL";
 214 }
 215
 216 sub todo {
 217     my $self = shift;
 218     my($gv, $cv, $is_form) = @_;
 219     my $seq;
 220     if (!null($cv->START) and is_state($cv->START)) {
 221         $seq = $cv->START->cop_seq;
 222     } else {
 223         $seq = 0;
 224     }
 225     push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
 226 }
 227
 228 sub next_todo {
 229     my $self = shift;
 230     my $ent = shift @{$self->{'subs_todo'}};
 231     my $name = $self->gv_name($ent->[1]);
 232     if ($ent->[2]) {
 233         return "format $name =\n"
 234             . $self->deparse_format($ent->[1]->FORM). "\n";
 235     } else {
 236         return "sub $name " . $self->deparse_sub($ent->[1]->CV);
 237     }
 238 }
 239
 240 sub walk_tree {
 241     my($op, $sub) = @_;
 242     $sub->($op);
 243     if ($op->flags & OPf_KIDS) {
 244         my $kid;
 245         for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
 246             walk_tree($kid, $sub);
 247         }
 248     }
 249 }
 250
 251 sub walk_sub {
 252     my $self = shift;
 253     my $cv = shift;
 254     my $op = $cv->ROOT;
 255     $op = shift if null $op;
 256     return if !$op or null $op;
 257     walk_tree($op, sub {
 258         my $op = shift;
 259         if ($op->name eq "gv") {
 260             my $gv = $self->gv_or_padgv($op);
 261             if ($op->next->name eq "entersub") {
 262                 return if $self->{'subs_done'}{$$gv}++;
 263                 return if class($gv->CV) eq "SPECIAL";
 264                 $self->todo($gv, $gv->CV, 0);
 265                 $self->walk_sub($gv->CV);
 266             } elsif ($op->next->name eq "enterwrite"
 267                      or ($op->next->name eq "rv2gv"
 268                          and $op->next->next->name eq "enterwrite")) {
 269                 return if $self->{'forms_done'}{$$gv}++;
 270                 return if class($gv->FORM) eq "SPECIAL";
 271                 $self->todo($gv, $gv->FORM, 1);
 272                 $self->walk_sub($gv->FORM);
 273             }
 274         }
 275     });
 276 }
 277
 278 sub stash_subs {
 279     my $self = shift;
 280     my $pack = shift;
 281     my(%stash, @ret);
 282     { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
 283     if ($pack eq "main") {
 284         $pack = "";
 285     } else {
 286         $pack = $pack . "::";
 287     }
 288     my($key, $val);
 289     while (($key, $val) = each %stash) {
 290         my $class = class($val);
 291         if ($class eq "PV") {
 292             # Just a prototype
 293             push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
 294         } elsif ($class eq "IV") {
 295             # Just a name
 296             push @{$self->{'protos_todo'}}, [$pack . $key, undef];
 297         } elsif ($class eq "GV") {
 298             if (class($val->CV) ne "SPECIAL") {
 299                 next if $self->{'subs_done'}{$$val}++;
 300                 $self->todo($val, $val->CV, 0);
 301                 $self->walk_sub($val->CV);
 302             }
 303             if (class($val->FORM) ne "SPECIAL") {
 304                 next if $self->{'forms_done'}{$$val}++;
 305                 $self->todo($val, $val->FORM, 1);
 306                 $self->walk_sub($val->FORM);
 307             }
 308         }
 309     }
 310 }
 311
 312 sub print_protos {
 313     my $self = shift;
 314     my $ar;
 315     my @ret;
 316     foreach $ar (@{$self->{'protos_todo'}}) {
 317         my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
 318         push @ret, "sub " . $ar->[0] .  "$proto;\n";
 319     }
 320     delete $self->{'protos_todo'};
 321     return @ret;
 322 }
 323
 324 sub style_opts {
 325     my $self = shift;
 326     my $opts = shift;
 327     my $opt;
 328     while (length($opt = substr($opts, 0, 1))) {
 329         if ($opt eq "C") {
 330             $self->{'cuddle'} = " ";
 331             $opts = substr($opts, 1);
 332         } elsif ($opt eq "i") {
 333             $opts =~ s/^i(\d+)//;
 334             $self->{'indent_size'} = $1;
 335         } elsif ($opt eq "T") {
 336             $self->{'use_tabs'} = 1;
 337             $opts = substr($opts, 1);
 338         } elsif ($opt eq "v") {
 339             $opts =~ s/^v([^.]*)(.|$)//;
 340             $self->{'ex_const'} = $1;
 341         }
 342     }
 343 }
 344
 345 sub new {
 346     my $class = shift;
 347     my $self = bless {}, $class;
 348     $self->{'subs_todo'} = [];
 349     $self->{'curstash'} = "main";
 350     $self->{'cuddle'} = "\n";
 351     $self->{'indent_size'} = 4;
 352     $self->{'use_tabs'} = 0;
 353     $self->{'ex_const'} = "'???'";
 354     while (my $arg = shift @_) {
 355         if (substr($arg, 0, 2) eq "-u") {
 356             $self->stash_subs(substr($arg, 2));
 357         } elsif ($arg eq "-p") {
 358             $self->{'parens'} = 1;
 359         } elsif ($arg eq "-l") {
 360             $self->{'linenums'} = 1;
 361         } elsif ($arg eq "-q") {
 362             $self->{'unquote'} = 1;
 363         } elsif (substr($arg, 0, 2) eq "-s") {
 364             $self->style_opts(substr $arg, 2);
 365         } elsif ($arg =~ /^-x(\d)$/) {
 366             $self->{'expand'} = $1;
 367         }
 368     }
 369     return $self;
 370 }
 371
 372 sub compile {
 373     my(@args) = @_;
 374     return sub {
 375         my $self = B::Deparse->new(@args);
 376         $self->stash_subs("main");
 377         $self->{'curcv'} = main_cv;
 378         $self->walk_sub(main_cv, main_start);
 379         print $self->print_protos;
 380         @{$self->{'subs_todo'}} =
 381           sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
 382         print $self->indent($self->deparse(main_root, 0)), "\n"
 383           unless null main_root;
 384         my @text;
 385         while (scalar(@{$self->{'subs_todo'}})) {
 386             push @text, $self->next_todo;
 387         }
 388         print $self->indent(join("", @text)), "\n" if @text;
 389     }
 390 }
 391
 392 sub coderef2text {
 393     my $self = shift;
 394     my $sub = shift;
 395     croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
 396     return $self->indent($self->deparse_sub(svref_2object($sub)));
 397 }
 398
 399 sub deparse {
 400     my $self = shift;
 401     my($op, $cx) = @_;
 402 #    cluck if class($op) eq "NULL";
 403 #    cluck unless $op;
 404 #    return $self->$ {\("pp_" . $op->name)}($op, $cx);
 405     my $meth = "pp_" . $op->name;
 406     return $self->$meth($op, $cx);
 407 }
 408
 409 sub indent {
 410     my $self = shift;
 411     my $txt = shift;
 412     my @lines = split(/\n/, $txt);
 413     my $leader = "";
 414     my $level = 0;
 415     my $line;
 416     for $line (@lines) {
 417         my $cmd = substr($line, 0, 1);
 418         if ($cmd eq "\t" or $cmd eq "\b") {
 419             $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
 420             if ($self->{'use_tabs'}) {
 421                 $leader = "\t" x ($level / 8) . " " x ($level % 8);
 422             } else {
 423                 $leader = " " x $level;
 424             }
 425             $line = substr($line, 1);
 426         }
 427         if (substr($line, 0, 1) eq "\f") {
 428             $line = substr($line, 1); # no indent
 429         } else {
 430             $line = $leader . $line;
 431         }
 432         $line =~ s/\cK;?//g;
 433     }
 434     return join("\n", @lines);
 435 }
 436
 437 sub deparse_sub {
 438     my $self = shift;
 439     my $cv = shift;
 440     my $proto = "";
 441     if ($cv->FLAGS & SVf_POK) {
 442         $proto = "(". $cv->PV . ") ";
 443     }
 444     if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
 445         $proto .= ": ";
 446         $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
 447         $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
 448         $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
 449     }
 450
 451     local($self->{'curcv'}) = $cv;
 452     local($self->{'curstash'}) = $self->{'curstash'};
 453     if (not null $cv->ROOT) {
 454         # skip leavesub
 455         return $proto . "{\n\t" .
 456             $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
 457     }
 458     my $sv = $cv->const_sv;
 459     if ($$sv) {
 460         # uh-oh. inlinable sub... format it differently
 461         return $proto . "{ " . const($sv) . " }\n";
 462     } else { # XSUB?
 463         return $proto  . "{}\n";
 464     }
 465 }
 466
 467 sub deparse_format {
 468     my $self = shift;
 469     my $form = shift;
 470     my @text;
 471     local($self->{'curcv'}) = $form;
 472     local($self->{'curstash'}) = $self->{'curstash'};
 473     my $op = $form->ROOT;
 474     my $kid;
 475     $op = $op->first->first; # skip leavewrite, lineseq
 476     while (not null $op) {
 477         $op = $op->sibling; # skip nextstate
 478         my @exprs;
 479         $kid = $op->first->sibling; # skip pushmark
 480         push @text, $self->const_sv($kid)->PV;
 481         $kid = $kid->sibling;
 482         for (; not null $kid; $kid = $kid->sibling) {
 483             push @exprs, $self->deparse($kid, 0);
 484         }
 485         push @text, join(", ", @exprs)."\n" if @exprs;
 486         $op = $op->sibling;
 487     }
 488     return join("", @text) . ".";
 489 }
 490
 491 sub is_scope {
 492     my $op = shift;
 493     return $op->name eq "leave" || $op->name eq "scope"
 494       || $op->name eq "lineseq"
 495         || ($op->name eq "null" && class($op) eq "UNOP"
 496             && (is_scope($op->first) || $op->first->name eq "enter"));
 497 }
 498
 499 sub is_state {
 500     my $name = $_[0]->name;
 501     return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
 502 }
 503
 504 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
 505     my $op = shift;
 506     return (!null($op) and null($op->sibling)
 507             and $op->name eq "null" and class($op) eq "UNOP"
 508             and (($op->first->name =~ /^(and|or)$/
 509                   and $op->first->first->sibling->name eq "lineseq")
 510                  or ($op->first->name eq "lineseq"
 511                      and not null $op->first->first->sibling
 512                      and $op->first->first->sibling->name eq "unstack")
 513                  ));
 514 }
 515
 516 sub is_scalar {
 517     my $op = shift;
 518     return ($op->name eq "rv2sv" or
 519             $op->name eq "padsv" or
 520             $op->name eq "gv" or # only in array/hash constructs
 521             $op->flags & OPf_KIDS && !null($op->first)
 522               && $op->first->name eq "gvsv");
 523 }
 524
 525 sub maybe_parens {
 526     my $self = shift;
 527     my($text, $cx, $prec) = @_;
 528     if ($prec < $cx              # unary ops nest just fine
 529         or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
 530         or $self->{'parens'})
 531     {
 532         $text = "($text)";
 533         # In a unop, let parent reuse our parens; see maybe_parens_unop
 534         $text = "\cS" . $text if $cx == 16;
 535         return $text;
 536     } else {
 537         return $text;
 538     }
 539 }
 540
 541 # same as above, but get around the `if it looks like a function' rule
 542 sub maybe_parens_unop {
 543     my $self = shift;
 544     my($name, $kid, $cx) = @_;
 545     if ($cx > 16 or $self->{'parens'}) {
 546         return "$name(" . $self->deparse($kid, 1) . ")";
 547     } else {
 548         $kid = $self->deparse($kid, 16);
 549         if (substr($kid, 0, 1) eq "\cS") {
 550             # use kid's parens
 551             return $name . substr($kid, 1);
 552         } elsif (substr($kid, 0, 1) eq "(") {
 553             # avoid looks-like-a-function trap with extra parens
 554             # (`+' can lead to ambiguities)
 555             return "$name(" . $kid  . ")";
 556         } else {
 557             return "$name $kid";
 558         }
 559     }
 560 }
 561
 562 sub maybe_parens_func {
 563     my $self = shift;
 564     my($func, $text, $cx, $prec) = @_;
 565     if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
 566         return "$func($text)";
 567     } else {
 568         return "$func $text";
 569     }
 570 }
 571
 572 sub maybe_local {
 573     my $self = shift;
 574     my($op, $cx, $text) = @_;
 575     if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
 576         if (want_scalar($op)) {
 577             return "local $text";
 578         } else {
 579             return $self->maybe_parens_func("local", $text, $cx, 16);
 580         }
 581     } else {
 582         return $text;
 583     }
 584 }
 585
 586 sub maybe_targmy {
 587     my $self = shift;
 588     my($op, $cx, $func, @args) = @_;
 589     if ($op->private & OPpTARGET_MY) {
 590         my $var = $self->padname($op->targ);
 591         my $val = $func->($self, $op, 7, @args);
 592         return $self->maybe_parens("$var = $val", $cx, 7);
 593     } else {
 594         return $func->($self, $op, $cx, @args);
 595     }
 596 }
 597
 598 sub padname_sv {
 599     my $self = shift;
 600     my $targ = shift;
 601     return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
 602 }
 603
 604 sub maybe_my {
 605     my $self = shift;
 606     my($op, $cx, $text) = @_;
 607     if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
 608         if (want_scalar($op)) {
 609             return "my $text";
 610         } else {
 611             return $self->maybe_parens_func("my", $text, $cx, 16);
 612         }
 613     } else {
 614         return $text;
 615     }
 616 }
 617
 618 # The following OPs don't have functions:
 619
 620 # pp_padany -- does not exist after parsing
 621 # pp_rcatline -- does not exist
 622
 623 sub pp_enter { # see also leave
 624     cluck "unexpected OP_ENTER";
 625     return "XXX";
 626 }
 627
 628 sub pp_pushmark { # see also list
 629     cluck "unexpected OP_PUSHMARK";
 630     return "XXX";
 631 }
 632
 633 sub pp_leavesub { # see also deparse_sub
 634     cluck "unexpected OP_LEAVESUB";
 635     return "XXX";
 636 }
 637
 638 sub pp_leavewrite { # see also deparse_format
 639     cluck "unexpected OP_LEAVEWRITE";
 640     return "XXX";
 641 }
 642
 643 sub pp_method { # see also entersub
 644     cluck "unexpected OP_METHOD";
 645     return "XXX";
 646 }
 647
 648 sub pp_regcmaybe { # see also regcomp
 649     cluck "unexpected OP_REGCMAYBE";
 650     return "XXX";
 651 }
 652
 653 sub pp_regcreset { # see also regcomp
 654     cluck "unexpected OP_REGCRESET";
 655     return "XXX";
 656 }
 657
 658 sub pp_substcont { # see also subst
 659     cluck "unexpected OP_SUBSTCONT";
 660     return "XXX";
 661 }
 662
 663 sub pp_grepstart { # see also grepwhile
 664     cluck "unexpected OP_GREPSTART";
 665     return "XXX";
 666 }
 667
 668 sub pp_mapstart { # see also mapwhile
 669     cluck "unexpected OP_MAPSTART";
 670     return "XXX";
 671 }
 672
 673 sub pp_flip { # see also flop
 674     cluck "unexpected OP_FLIP";
 675     return "XXX";
 676 }
 677
 678 sub pp_iter { # see also leaveloop
 679     cluck "unexpected OP_ITER";
 680     return "XXX";
 681 }
 682
 683 sub pp_enteriter { # see also leaveloop
 684     cluck "unexpected OP_ENTERITER";
 685     return "XXX";
 686 }
 687
 688 sub pp_enterloop { # see also leaveloop
 689     cluck "unexpected OP_ENTERLOOP";
 690     return "XXX";
 691 }
 692
 693 sub pp_leaveeval { # see also entereval
 694     cluck "unexpected OP_LEAVEEVAL";
 695     return "XXX";
 696 }
 697
 698 sub pp_entertry { # see also leavetry
 699     cluck "unexpected OP_ENTERTRY";
 700     return "XXX";
 701 }
 702
 703 sub lineseq {
 704     my $self = shift;
 705     my(@ops) = @_;
 706     my($expr, @exprs);
 707     for (my $i = 0; $i < @ops; $i++) {
 708         $expr = "";
 709         if (is_state $ops[$i]) {
 710             $expr = $self->deparse($ops[$i], 0);
 711             $i++;
 712             last if $i > $#ops;
 713         }
 714         if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and
 715             $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3)
 716         {
 717             push @exprs, $expr . $self->for_loop($ops[$i], 0);
 718             $i++;
 719             next;
 720         }
 721         $expr .= $self->deparse($ops[$i], 0);
 722         push @exprs, $expr if length $expr;
 723     }
 724     return join(";\n", @exprs);
 725 }
 726
 727 sub scopeop {
 728     my($real_block, $self, $op, $cx) = @_;
 729     my $kid;
 730     my @kids;
 731     local($self->{'curstash'}) = $self->{'curstash'} if $real_block;
 732     if ($real_block) {
 733         $kid = $op->first->sibling; # skip enter
 734         if (is_miniwhile($kid)) {
 735             my $top = $kid->first;
 736             my $name = $top->name;
 737             if ($name eq "and") {
 738                 $name = "while";
 739             } elsif ($name eq "or") {
 740                 $name = "until";
 741             } else { # no conditional -> while 1 or until 0
 742                 return $self->deparse($top->first, 1) . " while 1";
 743             }
 744             my $cond = $top->first;
 745             my $body = $cond->sibling->first; # skip lineseq
 746             $cond = $self->deparse($cond, 1);
 747             $body = $self->deparse($body, 1);
 748             return "$body $name $cond";
 749         }
 750     } else {
 751         $kid = $op->first;
 752     }
 753     for (; !null($kid); $kid = $kid->sibling) {
 754         push @kids, $kid;
 755     }
 756     if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
 757         return "do { " . $self->lineseq(@kids) . " }";
 758     } else {
 759         return $self->lineseq(@kids) . ";";
 760     }
 761 }
 762
 763 sub pp_scope { scopeop(0, @_); }
 764 sub pp_lineseq { scopeop(0, @_); }
 765 sub pp_leave { scopeop(1, @_); }
 766
 767 # The BEGIN {} is used here because otherwise this code isn't executed
 768 # when you run B::Deparse on itself.
 769 my %globalnames;
 770 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
 771             "ENV", "ARGV", "ARGVOUT", "_"); }
 772
 773 sub gv_name {
 774     my $self = shift;
 775     my $gv = shift;
 776     my $stash = $gv->STASH->NAME;
 777     my $name = $gv->SAFENAME;
 778     if ($stash eq $self->{'curstash'} or $globalnames{$name}
 779         or $name =~ /^[^A-Za-z_]/)
 780     {
 781         $stash = "";
 782     } else {
 783         $stash = $stash . "::";
 784     }
 785     if ($name =~ /^\^../) {
 786         $name = "{$name}";       # ${^WARNING_BITS} etc
 787     }
 788     return $stash . $name;
 789 }
 790
 791 # Notice how subs and formats are inserted between statements here
 792 sub pp_nextstate {
 793     my $self = shift;
 794     my($op, $cx) = @_;
 795     my @text;
 796     @text = $op->label . ": " if $op->label;
 797     my $seq = $op->cop_seq;
 798     while (scalar(@{$self->{'subs_todo'}})
 799            and $seq > $self->{'subs_todo'}[0][0]) {
 800         push @text, $self->next_todo;
 801     }
 802     my $stash = $op->stashpv;
 803     if ($stash ne $self->{'curstash'}) {
 804         push @text, "package $stash;\n";
 805         $self->{'curstash'} = $stash;
 806     }
 807     if ($self->{'linenums'}) {
 808         push @text, "\f#line " . $op->line .
 809           ' "' . $op->file, qq'"\n';
 810     }
 811     return join("", @text);
 812 }
 813
 814 sub pp_dbstate { pp_nextstate(@_) }
 815 sub pp_setstate { pp_nextstate(@_) }
 816
 817 sub pp_unstack { return "" } # see also leaveloop
 818
 819 sub baseop {
 820     my $self = shift;
 821     my($op, $cx, $name) = @_;
 822     return $name;
 823 }
 824
 825 sub pp_stub { baseop(@_, "()") }
 826 sub pp_wantarray { baseop(@_, "wantarray") }
 827 sub pp_fork { baseop(@_, "fork") }
 828 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
 829 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
 830 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
 831 sub pp_tms { baseop(@_, "times") }
 832 sub pp_ghostent { baseop(@_, "gethostent") }
 833 sub pp_gnetent { baseop(@_, "getnetent") }
 834 sub pp_gprotoent { baseop(@_, "getprotoent") }
 835 sub pp_gservent { baseop(@_, "getservent") }
 836 sub pp_ehostent { baseop(@_, "endhostent") }
 837 sub pp_enetent { baseop(@_, "endnetent") }
 838 sub pp_eprotoent { baseop(@_, "endprotoent") }
 839 sub pp_eservent { baseop(@_, "endservent") }
 840 sub pp_gpwent { baseop(@_, "getpwent") }
 841 sub pp_spwent { baseop(@_, "setpwent") }
 842 sub pp_epwent { baseop(@_, "endpwent") }
 843 sub pp_ggrent { baseop(@_, "getgrent") }
 844 sub pp_sgrent { baseop(@_, "setgrent") }
 845 sub pp_egrent { baseop(@_, "endgrent") }
 846 sub pp_getlogin { baseop(@_, "getlogin") }
 847
 848 sub POSTFIX () { 1 }
 849
 850 # I couldn't think of a good short name, but this is the category of
 851 # symbolic unary operators with interesting precedence
 852
 853 sub pfixop {
 854     my $self = shift;
 855     my($op, $cx, $name, $prec, $flags) = (@_, 0);
 856     my $kid = $op->first;
 857     $kid = $self->deparse($kid, $prec);
 858     return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
 859                                $cx, $prec);
 860 }
 861
 862 sub pp_preinc { pfixop(@_, "++", 23) }
 863 sub pp_predec { pfixop(@_, "--", 23) }
 864 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
 865 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
 866 sub pp_i_preinc { pfixop(@_, "++", 23) }
 867 sub pp_i_predec { pfixop(@_, "--", 23) }
 868 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
 869 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
 870 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
 871
 872 sub pp_negate { maybe_targmy(@_, \&real_negate) }
 873 sub real_negate {
 874     my $self = shift;
 875     my($op, $cx) = @_;
 876     if ($op->first->name =~ /^(i_)?negate$/) {
 877         # avoid --$x
 878         $self->pfixop($op, $cx, "-", 21.5);
 879     } else {
 880         $self->pfixop($op, $cx, "-", 21);
 881     }
 882 }
 883 sub pp_i_negate { pp_negate(@_) }
 884
 885 sub pp_not {
 886     my $self = shift;
 887     my($op, $cx) = @_;
 888     if ($cx <= 4) {
 889         $self->pfixop($op, $cx, "not ", 4);
 890     } else {
 891         $self->pfixop($op, $cx, "!", 21);
 892     }
 893 }
 894
 895 sub unop {
 896     my $self = shift;
 897     my($op, $cx, $name) = @_;
 898     my $kid;
 899     if ($op->flags & OPf_KIDS) {
 900         $kid = $op->first;
 901         return $self->maybe_parens_unop($name, $kid, $cx);
 902     } else {
 903         return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");
 904     }
 905 }
 906
 907 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
 908 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
 909 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
 910 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
 911 sub pp_defined { unop(@_, "defined") }
 912 sub pp_undef { unop(@_, "undef") }
 913 sub pp_study { unop(@_, "study") }
 914 sub pp_ref { unop(@_, "ref") }
 915 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
 916
 917 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
 918 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
 919 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
 920 sub pp_srand { unop(@_, "srand") }
 921 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
 922 sub pp_log { maybe_targmy(@_, \&unop, "log") }
 923 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
 924 sub pp_int { maybe_targmy(@_, \&unop, "int") }
 925 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
 926 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
 927 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
 928
 929 sub pp_length { maybe_targmy(@_, \&unop, "length") }
 930 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
 931 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
 932
 933 sub pp_each { unop(@_, "each") }
 934 sub pp_values { unop(@_, "values") }
 935 sub pp_keys { unop(@_, "keys") }
 936 sub pp_pop { unop(@_, "pop") }
 937 sub pp_shift { unop(@_, "shift") }
 938
 939 sub pp_caller { unop(@_, "caller") }
 940 sub pp_reset { unop(@_, "reset") }
 941 sub pp_exit { unop(@_, "exit") }
 942 sub pp_prototype { unop(@_, "prototype") }
 943
 944 sub pp_close { unop(@_, "close") }
 945 sub pp_fileno { unop(@_, "fileno") }
 946 sub pp_umask { unop(@_, "umask") }
 947 sub pp_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 sub padname {
1874     my $self = shift;
1875     my $targ = shift;
1876     return $self->padname_sv($targ)->PVX;
1877 }
1878
1879 sub padany {
1880     my $self = shift;
1881     my $op = shift;
1882     return substr($self->padname($op->targ), 1); # skip $/@/%
1883 }
1884
1885 sub pp_padsv {
1886     my $self = shift;
1887     my($op, $cx) = @_;
1888     return $self->maybe_my($op, $cx, $self->padname($op->targ));
1889 }
1890
1891 sub pp_padav { pp_padsv(@_) }
1892 sub pp_padhv { pp_padsv(@_) }
1893
1894 my @threadsv_names;
1895
1896 BEGIN {
1897     @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1898                        "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1899                        "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1900                        "!", "@");
1901 }
1902
1903 sub pp_threadsv {
1904     my $self = shift;
1905     my($op, $cx) = @_;
1906     return $self->maybe_local($op, $cx, "\$" .  $threadsv_names[$op->targ]);
1907 }
1908
1909 sub gv_or_padgv {
1910     my $self = shift;
1911     my $op = shift;
1912     if (class($op) eq "PADOP") {
1913         return $self->padval($op->padix);
1914     } else { # class($op) eq "SVOP"
1915         return $op->gv;
1916     }
1917 }
1918
1919 sub pp_gvsv {
1920     my $self = shift;
1921     my($op, $cx) = @_;
1922     my $gv = $self->gv_or_padgv($op);
1923     return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv));
1924 }
1925
1926 sub pp_gv {
1927     my $self = shift;
1928     my($op, $cx) = @_;
1929     my $gv = $self->gv_or_padgv($op);
1930     return $self->gv_name($gv);
1931 }
1932
1933 sub pp_aelemfast {
1934     my $self = shift;
1935     my($op, $cx) = @_;
1936     my $gv = $self->gv_or_padgv($op);
1937     return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1938 }
1939
1940 sub rv2x {
1941     my $self = shift;
1942     my($op, $cx, $type) = @_;
1943     my $kid = $op->first;
1944     my $str = $self->deparse($kid, 0);
1945     return $type . (is_scalar($kid) ? $str : "{$str}");
1946 }
1947
1948 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1949 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1950 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1951
1952 # skip rv2av
1953 sub pp_av2arylen {
1954     my $self = shift;
1955     my($op, $cx) = @_;
1956     if ($op->first->name eq "padav") {
1957         return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
1958     } else {
1959         return $self->maybe_local($op, $cx,
1960                                   $self->rv2x($op->first, $cx, '$#'));
1961     }
1962 }
1963
1964 # skip down to the old, ex-rv2cv
1965 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
1966
1967 sub pp_rv2av {
1968     my $self = shift;
1969     my($op, $cx) = @_;
1970     my $kid = $op->first;
1971     if ($kid->name eq "const") { # constant list
1972         my $av = $self->const_sv($kid);
1973         return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1974     } else {
1975         return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
1976     }
1977  }
1978
1979 sub is_subscriptable {
1980     my $op = shift;
1981     if ($op->name =~ /^[ahg]elem/) {
1982         return 1;
1983     } elsif ($op->name eq "entersub") {
1984         my $kid = $op->first;
1985         return 0 unless null $kid->sibling;
1986         $kid = $kid->first;
1987         $kid = $kid->sibling until null $kid->sibling;
1988         return 0 if is_scope($kid);
1989         $kid = $kid->first;
1990         return 0 if $kid->name eq "gv";
1991         return 0 if is_scalar($kid);
1992         return is_subscriptable($kid);
1993     } else {
1994         return 0;
1995     }
1996 }
1997
1998 sub elem {
1999     my $self = shift;
2000     my ($op, $cx, $left, $right, $padname) = @_;
2001     my($array, $idx) = ($op->first, $op->first->sibling);
2002     unless ($array->name eq $padname) { # Maybe this has been fixed
2003         $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2004     }
2005     if ($array->name eq $padname) {
2006         $array = $self->padany($array);
2007     } elsif (is_scope($array)) { # ${expr}[0]
2008         $array = "{" . $self->deparse($array, 0) . "}";
2009     } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2010         $array = $self->deparse($array, 24);
2011     } else {
2012         # $x[20][3]{hi} or expr->[20]
2013         my $arrow = is_subscriptable($array) ? "" : "->";
2014         return $self->deparse($array, 24) . $arrow .
2015             $left . $self->deparse($idx, 1) . $right;
2016     }
2017     $idx = $self->deparse($idx, 1);
2018     return "\$" . $array . $left . $idx . $right;
2019 }
2020
2021 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2022 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2023
2024 sub pp_gelem {
2025     my $self = shift;
2026     my($op, $cx) = @_;
2027     my($glob, $part) = ($op->first, $op->last);
2028     $glob = $glob->first; # skip rv2gv
2029     $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2030     my $scope = is_scope($glob);
2031     $glob = $self->deparse($glob, 0);
2032     $part = $self->deparse($part, 1);
2033     return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2034 }
2035
2036 sub slice {
2037     my $self = shift;
2038     my ($op, $cx, $left, $right, $regname, $padname) = @_;
2039     my $last;
2040     my(@elems, $kid, $array, $list);
2041     if (class($op) eq "LISTOP") {
2042         $last = $op->last;
2043     } else { # ex-hslice inside delete()
2044         for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2045         $last = $kid;
2046     }
2047     $array = $last;
2048     $array = $array->first
2049         if $array->name eq $regname or $array->name eq "null";
2050     if (is_scope($array)) {
2051         $array = "{" . $self->deparse($array, 0) . "}";
2052     } elsif ($array->name eq $padname) {
2053         $array = $self->padany($array);
2054     } else {
2055         $array = $self->deparse($array, 24);
2056     }
2057     $kid = $op->first->sibling; # skip pushmark
2058     if ($kid->name eq "list") {
2059         $kid = $kid->first->sibling; # skip list, pushmark
2060         for (; !null $kid; $kid = $kid->sibling) {
2061             push @elems, $self->deparse($kid, 6);
2062         }
2063         $list = join(", ", @elems);
2064     } else {
2065         $list = $self->deparse($kid, 1);
2066     }
2067     return "\@" . $array . $left . $list . $right;
2068 }
2069
2070 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2071 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2072
2073 sub pp_lslice {
2074     my $self = shift;
2075     my($op, $cx) = @_;
2076     my $idx = $op->first;
2077     my $list = $op->last;
2078     my(@elems, $kid);
2079     $list = $self->deparse($list, 1);
2080     $idx = $self->deparse($idx, 1);
2081     return "($list)" . "[$idx]";
2082 }
2083
2084 sub want_scalar {
2085     my $op = shift;
2086     return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2087 }
2088
2089 sub want_list {
2090     my $op = shift;
2091     return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2092 }
2093
2094 sub method {
2095     my $self = shift;
2096     my($op, $cx) = @_;
2097     my $kid = $op->first->sibling; # skip pushmark
2098     my($meth, $obj, @exprs);
2099     if ($kid->name eq "list" and want_list $kid) {
2100         # When an indirect object isn't a bareword but the args are in
2101         # parens, the parens aren't part of the method syntax (the LLAFR
2102         # doesn't apply), but they make a list with OPf_PARENS set that
2103         # doesn't get flattened by the append_elem that adds the method,
2104         # making a (object, arg1, arg2, ...) list where the object
2105         # usually is. This can be distinguished from
2106         # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2107         # object) because in the later the list is in scalar context
2108         # as the left side of -> always is, while in the former
2109         # the list is in list context as method arguments always are.
2110         # (Good thing there aren't method prototypes!)
2111         $meth = $kid->sibling;
2112         $kid = $kid->first->sibling; # skip pushmark
2113         $obj = $kid;
2114         $kid = $kid->sibling;
2115         for (; not null $kid; $kid = $kid->sibling) {
2116             push @exprs, $self->deparse($kid, 6);
2117         }
2118     } else {
2119         $obj = $kid;
2120         $kid = $kid->sibling;
2121         for (; not null $kid->sibling; $kid = $kid->sibling) {
2122             push @exprs, $self->deparse($kid, 6);
2123         }
2124         $meth = $kid;
2125     }
2126     $obj = $self->deparse($obj, 24);
2127     if ($meth->name eq "method_named") {
2128         $meth = $self->const_sv($meth)->PV;
2129     } else {
2130         $meth = $meth->first;
2131         if ($meth->name eq "const") {
2132             # As of 5.005_58, this case is probably obsoleted by the
2133             # method_named case above
2134             $meth = $self->const_sv($meth)->PV; # needs to be bare
2135         } else {
2136             $meth = $self->deparse($meth, 1);
2137         }
2138     }
2139     my $args = join(", ", @exprs);
2140     $kid = $obj . "->" . $meth;
2141     if ($args) {
2142         return $kid . "(" . $args . ")"; # parens mandatory
2143     } else {
2144         return $kid;
2145     }
2146 }
2147
2148 # returns "&" if the prototype doesn't match the args,
2149 # or ("", $args_after_prototype_demunging) if it does.
2150 sub check_proto {
2151     my $self = shift;
2152     my($proto, @args) = @_;
2153     my($arg, $real);
2154     my $doneok = 0;
2155     my @reals;
2156     # An unbackslashed @ or % gobbles up the rest of the args
2157     $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2158     while ($proto) {
2159         $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2160         my $chr = $1;
2161         if ($chr eq "") {
2162             return "&" if @args;
2163         } elsif ($chr eq ";") {
2164             $doneok = 1;
2165         } elsif ($chr eq "@" or $chr eq "%") {
2166             push @reals, map($self->deparse($_, 6), @args);
2167             @args = ();
2168         } else {
2169             $arg = shift @args;
2170             last unless $arg;
2171             if ($chr eq "\$") {
2172                 if (want_scalar $arg) {
2173                     push @reals, $self->deparse($arg, 6);
2174                 } else {
2175                     return "&";
2176                 }
2177             } elsif ($chr eq "&") {
2178                 if ($arg->name =~ /^(s?refgen|undef)$/) {
2179                     push @reals, $self->deparse($arg, 6);
2180                 } else {
2181                     return "&";
2182                 }
2183             } elsif ($chr eq "*") {
2184                 if ($arg->name =~ /^s?refgen$/
2185                     and $arg->first->first->name eq "rv2gv")
2186                   {
2187                       $real = $arg->first->first; # skip refgen, null
2188                       if ($real->first->name eq "gv") {
2189                           push @reals, $self->deparse($real, 6);
2190                       } else {
2191                           push @reals, $self->deparse($real->first, 6);
2192                       }
2193                   } else {
2194                       return "&";
2195                   }
2196             } elsif (substr($chr, 0, 1) eq "\\") {
2197                 $chr = substr($chr, 1);
2198                 if ($arg->name =~ /^s?refgen$/ and
2199                     !null($real = $arg->first) and
2200                     ($chr eq "\$" && is_scalar($real->first)
2201                      or ($chr eq "\@"
2202                          && $real->first->sibling->name
2203                          =~ /^(rv2|pad)av$/)
2204                      or ($chr eq "%"
2205                          && $real->first->sibling->name
2206                          =~ /^(rv2|pad)hv$/)
2207                      #or ($chr eq "&" # This doesn't work
2208                      #   && $real->first->name eq "rv2cv")
2209                      or ($chr eq "*"
2210                          && $real->first->name eq "rv2gv")))
2211                   {
2212                       push @reals, $self->deparse($real, 6);
2213                   } else {
2214                       return "&";
2215                   }
2216             }
2217        }
2218     }
2219     return "&" if $proto and !$doneok; # too few args and no `;'
2220     return "&" if @args;               # too many args
2221     return ("", join ", ", @reals);
2222 }
2223
2224 sub pp_entersub {
2225     my $self = shift;
2226     my($op, $cx) = @_;
2227     return $self->method($op, $cx) unless null $op->first->sibling;
2228     my $prefix = "";
2229     my $amper = "";
2230     my($kid, @exprs);
2231     if ($op->flags & OPf_SPECIAL) {
2232         $prefix = "do ";
2233     } elsif ($op->private & OPpENTERSUB_AMPER) {
2234         $amper = "&";
2235     }
2236     $kid = $op->first;
2237     $kid = $kid->first->sibling; # skip ex-list, pushmark
2238     for (; not null $kid->sibling; $kid = $kid->sibling) {
2239         push @exprs, $kid;
2240     }
2241     my $simple = 0;
2242     my $proto = undef;
2243     if (is_scope($kid)) {
2244         $amper = "&";
2245         $kid = "{" . $self->deparse($kid, 0) . "}";
2246     } elsif ($kid->first->name eq "gv") {
2247         my $gv = $self->gv_or_padgv($kid->first);
2248         if (class($gv->CV) ne "SPECIAL") {
2249             $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2250         }
2251         $simple = 1; # only calls of named functions can be prototyped
2252         $kid = $self->deparse($kid, 24);
2253     } elsif (is_scalar $kid->first) {
2254         $amper = "&";
2255         $kid = $self->deparse($kid, 24);
2256     } else {
2257         $prefix = "";
2258         my $arrow = is_subscriptable($kid->first) ? "" : "->";
2259         $kid = $self->deparse($kid, 24) . $arrow;
2260     }
2261     my $args;
2262     if (defined $proto and not $amper) {
2263         ($amper, $args) = $self->check_proto($proto, @exprs);
2264         if ($amper eq "&") {
2265             $args = join(", ", map($self->deparse($_, 6), @exprs));
2266         }
2267     } else {
2268         $args = join(", ", map($self->deparse($_, 6), @exprs));
2269     }
2270     if ($prefix or $amper) {
2271         if ($op->flags & OPf_STACKED) {
2272             return $prefix . $amper . $kid . "(" . $args . ")";
2273         } else {
2274             return $prefix . $amper. $kid;
2275         }
2276     } else {
2277         if (defined $proto and $proto eq "") {
2278             return $kid;
2279         } elsif (defined $proto and $proto eq "\$") {
2280             return $self->maybe_parens_func($kid, $args, $cx, 16);
2281         } elsif (defined($proto) && $proto or $simple) {
2282             return $self->maybe_parens_func($kid, $args, $cx, 5);
2283         } else {
2284             return "$kid(" . $args . ")";
2285         }
2286     }
2287 }
2288
2289 sub pp_enterwrite { unop(@_, "write") }
2290
2291 # escape things that cause interpolation in double quotes,
2292 # but not character escapes
2293 sub uninterp {
2294     my($str) = @_;
2295     $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2296     return $str;
2297 }
2298
2299 # the same, but treat $|, $), and $ at the end of the string differently
2300 sub re_uninterp {
2301     my($str) = @_;
2302     $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2303     $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2304     return $str;
2305 }
2306
2307 # character escapes, but not delimiters that might need to be escaped
2308 sub escape_str { # ASCII
2309     my($str) = @_;
2310     $str =~ s/\a/\\a/g;
2311 #    $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2312     $str =~ s/\t/\\t/g;
2313     $str =~ s/\n/\\n/g;
2314     $str =~ s/\e/\\e/g;
2315     $str =~ s/\f/\\f/g;
2316     $str =~ s/\r/\\r/g;
2317     $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2318     $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2319     return $str;
2320 }
2321
2322 # Don't do this for regexen
2323 sub unback {
2324     my($str) = @_;
2325     $str =~ s/\\/\\\\/g;
2326     return $str;
2327 }
2328
2329 sub balanced_delim {
2330     my($str) = @_;
2331     my @str = split //, $str;
2332     my($ar, $open, $close, $fail, $c, $cnt);
2333     for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2334         ($open, $close) = @$ar;
2335         $fail = 0; $cnt = 0;
2336         for $c (@str) {
2337             if ($c eq $open) {
2338                 $cnt++;
2339             } elsif ($c eq $close) {
2340                 $cnt--;
2341                 if ($cnt < 0) {
2342                     # qq()() isn't ")("
2343                     $fail = 1;
2344                     last;
2345                 }
2346             }
2347         }
2348         $fail = 1 if $cnt != 0;
2349         return ($open, "$open$str$close") if not $fail;
2350     }
2351     return ("", $str);
2352 }
2353
2354 sub single_delim {
2355     my($q, $default, $str) = @_;
2356     return "$default$str$default" if $default and index($str, $default) == -1;
2357     my($succeed, $delim);
2358     ($succeed, $str) = balanced_delim($str);
2359     return "$q$str" if $succeed;
2360     for $delim ('/', '"', '#') {
2361         return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2362     }
2363     if ($default) {
2364         $str =~ s/$default/\\$default/g;
2365         return "$default$str$default";
2366     } else {
2367         $str =~ s[/][\\/]g;
2368         return "$q/$str/";
2369     }
2370 }
2371
2372 sub const {
2373     my $sv = shift;
2374     if (class($sv) eq "SPECIAL") {
2375         return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2376     } elsif ($sv->FLAGS & SVf_IOK) {
2377         return $sv->int_value;
2378     } elsif ($sv->FLAGS & SVf_NOK) {
2379         return $sv->NV;
2380     } elsif ($sv->FLAGS & SVf_ROK) {
2381         return "\\(" . const($sv->RV) . ")"; # constant folded
2382     } else {
2383         my $str = $sv->PV;
2384         if ($str =~ /[^ -~]/) { # ASCII for non-printing
2385             return single_delim("qq", '"', uninterp escape_str unback $str);
2386         } else {
2387             return single_delim("q", "'", unback $str);
2388         }
2389     }
2390 }
2391
2392 sub const_sv {
2393     my $self = shift;
2394     my $op = shift;
2395     my $sv = $op->sv;
2396     # the constant could be in the pad (under useithreads)
2397     $sv = $self->padval($op->targ) unless $$sv;
2398     return $sv;
2399 }
2400
2401 sub pp_const {
2402     my $self = shift;
2403     my($op, $cx) = @_;
2404 #    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2405 #       return $self->const_sv($op)->PV;
2406 #    }
2407     my $sv = $self->const_sv($op);
2408 #    return const($sv);
2409     my $c = const $sv;
2410     return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
2411 }
2412
2413 sub dq {
2414     my $self = shift;
2415     my $op = shift;
2416     my $type = $op->name;
2417     if ($type eq "const") {
2418         return uninterp(escape_str(unback($self->const_sv($op)->PV)));
2419     } elsif ($type eq "concat") {
2420         return $self->dq($op->first) . $self->dq($op->last);
2421     } elsif ($type eq "uc") {
2422         return '\U' . $self->dq($op->first->sibling) . '\E';
2423     } elsif ($type eq "lc") {
2424         return '\L' . $self->dq($op->first->sibling) . '\E';
2425     } elsif ($type eq "ucfirst") {
2426         return '\u' . $self->dq($op->first->sibling);
2427     } elsif ($type eq "lcfirst") {
2428         return '\l' . $self->dq($op->first->sibling);
2429     } elsif ($type eq "quotemeta") {
2430         return '\Q' . $self->dq($op->first->sibling) . '\E';
2431     } elsif ($type eq "join") {
2432         return $self->deparse($op->last, 26); # was join($", @ary)
2433     } else {
2434         return $self->deparse($op, 26);
2435     }
2436 }
2437
2438 sub pp_backtick {
2439     my $self = shift;
2440     my($op, $cx) = @_;
2441     # skip pushmark
2442     return single_delim("qx", '`', $self->dq($op->first->sibling));
2443 }
2444
2445 sub dquote {
2446     my $self = shift;
2447     my($op, $cx) = @_;
2448     my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2449     return $self->deparse($kid, $cx) if $self->{'unquote'};
2450     $self->maybe_targmy($kid, $cx,
2451                         sub {single_delim("qq", '"', $self->dq($_[1]))});
2452 }
2453
2454 # OP_STRINGIFY is a listop, but it only ever has one arg
2455 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2456
2457 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2458 # note that tr(from)/to/ is OK, but not tr/from/(to)
2459 sub double_delim {
2460     my($from, $to) = @_;
2461     my($succeed, $delim);
2462     if ($from !~ m[/] and $to !~ m[/]) {
2463         return "/$from/$to/";
2464     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2465         if (($succeed, $to) = balanced_delim($to) and $succeed) {
2466             return "$from$to";
2467         } else {
2468             for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2469                 return "$from$delim$to$delim" if index($to, $delim) == -1;
2470             }
2471             $to =~ s[/][\\/]g;
2472             return "$from/$to/";
2473         }
2474     } else {
2475         for $delim ('/', '"', '#') { # note no '
2476             return "$delim$from$delim$to$delim"
2477                 if index($to . $from, $delim) == -1;
2478         }
2479         $from =~ s[/][\\/]g;
2480         $to =~ s[/][\\/]g;
2481         return "/$from/$to/";
2482     }
2483 }
2484
2485 sub pchr { # ASCII
2486     my($n) = @_;
2487     if ($n == ord '\\') {
2488         return '\\\\';
2489     } elsif ($n >= ord(' ') and $n <= ord('~')) {
2490         return chr($n);
2491     } elsif ($n == ord "\a") {
2492         return '\\a';
2493     } elsif ($n == ord "\b") {
2494         return '\\b';
2495     } elsif ($n == ord "\t") {
2496         return '\\t';
2497     } elsif ($n == ord "\n") {
2498         return '\\n';
2499     } elsif ($n == ord "\e") {
2500         return '\\e';
2501     } elsif ($n == ord "\f") {
2502         return '\\f';
2503     } elsif ($n == ord "\r") {
2504         return '\\r';
2505     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2506         return '\\c' . chr(ord("@") + $n);
2507     } else {
2508 #       return '\x' . sprintf("%02x", $n);
2509         return '\\' . sprintf("%03o", $n);
2510     }
2511 }
2512
2513 sub collapse {
2514     my(@chars) = @_;
2515     my($str, $c, $tr) = ("");
2516     for ($c = 0; $c < @chars; $c++) {
2517         $tr = $chars[$c];
2518         $str .= pchr($tr);
2519         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2520             $chars[$c + 2] == $tr + 2)
2521         {
2522             for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
2523               {}
2524             $str .= "-";
2525             $str .= pchr($chars[$c]);
2526         }
2527     }
2528     return $str;
2529 }
2530
2531 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
2532 # and backslashes.
2533
2534 sub tr_decode_byte {
2535     my($table, $flags) = @_;
2536     my(@table) = unpack("s256", $table);
2537     my($c, $tr, @from, @to, @delfrom, $delhyphen);
2538     if ($table[ord "-"] != -1 and
2539         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2540     {
2541         $tr = $table[ord "-"];
2542         $table[ord "-"] = -1;
2543         if ($tr >= 0) {
2544             @from = ord("-");
2545             @to = $tr;
2546         } else { # -2 ==> delete
2547             $delhyphen = 1;
2548         }
2549     }
2550     for ($c = 0; $c < 256; $c++) {
2551         $tr = $table[$c];
2552         if ($tr >= 0) {
2553             push @from, $c; push @to, $tr;
2554         } elsif ($tr == -2) {
2555             push @delfrom, $c;
2556         }
2557     }
2558     @from = (@from, @delfrom);
2559     if ($flags & OPpTRANS_COMPLEMENT) {
2560         my @newfrom = ();
2561         my %from;
2562         @from{@from} = (1) x @from;
2563         for ($c = 0; $c < 256; $c++) {
2564             push @newfrom, $c unless $from{$c};
2565         }
2566         @from = @newfrom;
2567     }
2568     unless ($flags & OPpTRANS_DELETE || !@to) {
2569         pop @to while $#to and $to[$#to] == $to[$#to -1];
2570     }
2571     my($from, $to);
2572     $from = collapse(@from);
2573     $to = collapse(@to);
2574     $from .= "-" if $delhyphen;
2575     return ($from, $to);
2576 }
2577
2578 sub tr_chr {
2579     my $x = shift;
2580     if ($x == ord "-") {
2581         return "\\-";
2582     } else {
2583         return chr $x;
2584     }
2585 }
2586
2587 # XXX This doesn't yet handle all cases correctly either
2588
2589 sub tr_decode_utf8 {
2590     my($swash_hv, $flags) = @_;
2591     my %swash = $swash_hv->ARRAY;
2592     my $final = undef;
2593     $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
2594     my $none = $swash{"NONE"}->IV;
2595     my $extra = $none + 1;
2596     my(@from, @delfrom, @to);
2597     my $line;
2598     foreach $line (split /\n/, $swash{'LIST'}->PV) {
2599         my($min, $max, $result) = split(/\t/, $line);
2600         $min = hex $min;
2601         if (length $max) {
2602             $max = hex $max;
2603         } else {
2604             $max = $min;
2605         }
2606         $result = hex $result;
2607         if ($result == $extra) {
2608             push @delfrom, [$min, $max];
2609         } else {
2610             push @from, [$min, $max];
2611             push @to, [$result, $result + $max - $min];
2612         }
2613     }
2614     for my $i (0 .. $#from) {
2615         if ($from[$i][0] == ord '-') {
2616             unshift @from, splice(@from, $i, 1);
2617             unshift @to, splice(@to, $i, 1);
2618             last;
2619         } elsif ($from[$i][1] == ord '-') {
2620             $from[$i][1]--;
2621             $to[$i][1]--;
2622             unshift @from, ord '-';
2623             unshift @to, ord '-';
2624             last;
2625         }
2626     }
2627     for my $i (0 .. $#delfrom) {
2628         if ($delfrom[$i][0] == ord '-') {
2629             push @delfrom, splice(@delfrom, $i, 1);
2630             last;
2631         } elsif ($delfrom[$i][1] == ord '-') {
2632             $delfrom[$i][1]--;
2633             push @delfrom, ord '-';
2634             last;
2635         }
2636     }
2637     if (defined $final and $to[$#to][1] != $final) {
2638         push @to, [$final, $final];
2639     }
2640     push @from, @delfrom;
2641     if ($flags & OPpTRANS_COMPLEMENT) {
2642         my @newfrom;
2643         my $next = 0;
2644         for my $i (0 .. $#from) {
2645             push @newfrom, [$next, $from[$i][0] - 1];
2646             $next = $from[$i][1] + 1;
2647         }
2648         @from = ();
2649         for my $range (@newfrom) {
2650             if ($range->[0] <= $range->[1]) {
2651                 push @from, $range;
2652             }
2653         }
2654     }
2655     my($from, $to, $diff);
2656     for my $chunk (@from) {
2657         $diff = $chunk->[1] - $chunk->[0];
2658         if ($diff > 1) {
2659             $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2660         } elsif ($diff == 1) {
2661             $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2662         } else {
2663             $from .= tr_chr($chunk->[0]);
2664         }
2665     }
2666     for my $chunk (@to) {
2667         $diff = $chunk->[1] - $chunk->[0];
2668         if ($diff > 1) {
2669             $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2670         } elsif ($diff == 1) {
2671             $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2672         } else {
2673             $to .= tr_chr($chunk->[0]);
2674         }
2675     }
2676     #$final = sprintf("%04x", $final) if defined $final;
2677     #$none = sprintf("%04x", $none) if defined $none;
2678     #$extra = sprintf("%04x", $extra) if defined $extra;
2679     #print STDERR "final: $final\n none: $none\nextra: $extra\n";
2680     #print STDERR $swash{'LIST'}->PV;
2681     return (escape_str($from), escape_str($to));
2682 }
2683
2684 sub pp_trans {
2685     my $self = shift;
2686     my($op, $cx) = @_;
2687     my($from, $to);
2688     if (class($op) eq "PVOP") {
2689         ($from, $to) = tr_decode_byte($op->pv, $op->private);
2690     } else { # class($op) eq "SVOP"
2691         ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
2692     }
2693     my $flags = "";
2694     $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
2695     $flags .= "d" if $op->private & OPpTRANS_DELETE;
2696     $to = "" if $from eq $to and $flags eq "";
2697     $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2698     return "tr" . double_delim($from, $to) . $flags;
2699 }
2700
2701 # Like dq(), but different
2702 sub re_dq {
2703     my $self = shift;
2704     my $op = shift;
2705     my $type = $op->name;
2706     if ($type eq "const") {
2707         return uninterp($self->const_sv($op)->PV);
2708     } elsif ($type eq "concat") {
2709         return $self->re_dq($op->first) . $self->re_dq($op->last);
2710     } elsif ($type eq "uc") {
2711         return '\U' . $self->re_dq($op->first->sibling) . '\E';
2712     } elsif ($type eq "lc") {
2713         return '\L' . $self->re_dq($op->first->sibling) . '\E';
2714     } elsif ($type eq "ucfirst") {
2715         return '\u' . $self->re_dq($op->first->sibling);
2716     } elsif ($type eq "lcfirst") {
2717         return '\l' . $self->re_dq($op->first->sibling);
2718     } elsif ($type eq "quotemeta") {
2719         return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2720     } elsif ($type eq "join") {
2721         return $self->deparse($op->last, 26); # was join($", @ary)
2722     } else {
2723         return $self->deparse($op, 26);
2724     }
2725 }
2726
2727 sub pp_regcomp {
2728     my $self = shift;
2729     my($op, $cx) = @_;
2730     my $kid = $op->first;
2731     $kid = $kid->first if $kid->name eq "regcmaybe";
2732     $kid = $kid->first if $kid->name eq "regcreset";
2733     return $self->re_dq($kid);
2734 }
2735
2736 # osmic acid -- see osmium tetroxide
2737
2738 my %matchwords;
2739 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2740     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2741     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2742
2743 sub matchop {
2744     my $self = shift;
2745     my($op, $cx, $name, $delim) = @_;
2746     my $kid = $op->first;
2747     my ($binop, $var, $re) = ("", "", "");
2748     if ($op->flags & OPf_STACKED) {
2749         $binop = 1;
2750         $var = $self->deparse($kid, 20);
2751         $kid = $kid->sibling;
2752     }
2753     if (null $kid) {
2754         $re = re_uninterp(escape_str($op->precomp));
2755     } else {
2756         $re = $self->deparse($kid, 1);
2757     }
2758     my $flags = "";
2759     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2760     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2761     $flags .= "i" if $op->pmflags & PMf_FOLD;
2762     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2763     $flags .= "o" if $op->pmflags & PMf_KEEP;
2764     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2765     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2766     $flags = $matchwords{$flags} if $matchwords{$flags};
2767     if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2768         $re =~ s/\?/\\?/g;
2769         $re = "?$re?";
2770     } else {
2771         $re = single_delim($name, $delim, $re);
2772     }
2773     $re = $re . $flags;
2774     if ($binop) {
2775         return $self->maybe_parens("$var =~ $re", $cx, 20);
2776     } else {
2777         return $re;
2778     }
2779 }
2780
2781 sub pp_match { matchop(@_, "m", "/") }
2782 sub pp_pushre { matchop(@_, "m", "/") }
2783 sub pp_qr { matchop(@_, "qr", "") }
2784
2785 sub pp_split {
2786     my $self = shift;
2787     my($op, $cx) = @_;
2788     my($kid, @exprs, $ary, $expr);
2789     $kid = $op->first;
2790     if ($ {$kid->pmreplroot}) {
2791         $ary = '@' . $self->gv_name($kid->pmreplroot);
2792     }
2793     for (; !null($kid); $kid = $kid->sibling) {
2794         push @exprs, $self->deparse($kid, 6);
2795     }
2796     $expr = "split(" . join(", ", @exprs) . ")";
2797     if ($ary) {
2798         return $self->maybe_parens("$ary = $expr", $cx, 7);
2799     } else {
2800         return $expr;
2801     }
2802 }
2803
2804 # oxime -- any of various compounds obtained chiefly by the action of
2805 # hydroxylamine on aldehydes and ketones and characterized by the
2806 # bivalent grouping C=NOH [Webster's Tenth]
2807
2808 my %substwords;
2809 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2810     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2811     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2812     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2813
2814 sub pp_subst {
2815     my $self = shift;
2816     my($op, $cx) = @_;
2817     my $kid = $op->first;
2818     my($binop, $var, $re, $repl) = ("", "", "", "");
2819     if ($op->flags & OPf_STACKED) {
2820         $binop = 1;
2821         $var = $self->deparse($kid, 20);
2822         $kid = $kid->sibling;
2823     }
2824     my $flags = "";
2825     if (null($op->pmreplroot)) {
2826         $repl = $self->dq($kid);
2827         $kid = $kid->sibling;
2828     } else {
2829         $repl = $op->pmreplroot->first; # skip substcont
2830         while ($repl->name eq "entereval") {
2831             $repl = $repl->first;
2832             $flags .= "e";
2833         }
2834         if ($op->pmflags & PMf_EVAL) {
2835             $repl = $self->deparse($repl, 0);
2836         } else {
2837             $repl = $self->dq($repl);
2838         }
2839     }
2840     if (null $kid) {
2841         $re = re_uninterp(escape_str($op->precomp));
2842     } else {
2843         $re = $self->deparse($kid, 1);
2844     }
2845     $flags .= "e" if $op->pmflags & PMf_EVAL;
2846     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2847     $flags .= "i" if $op->pmflags & PMf_FOLD;
2848     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2849     $flags .= "o" if $op->pmflags & PMf_KEEP;
2850     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2851     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2852     $flags = $substwords{$flags} if $substwords{$flags};
2853     if ($binop) {
2854         return $self->maybe_parens("$var =~ s"
2855                                    . double_delim($re, $repl) . $flags,
2856                                    $cx, 20);
2857     } else {
2858         return "s". double_delim($re, $repl) . $flags;
2859     }
2860 }
2861
2862 1;
2863 __END__
2864
2865 =head1 NAME
2866
2867 B::Deparse - Perl compiler backend to produce perl code
2868
2869 =head1 SYNOPSIS
2870
2871 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
2872         [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
2873
2874 =head1 DESCRIPTION
2875
2876 B::Deparse is a backend module for the Perl compiler that generates
2877 perl source code, based on the internal compiled structure that perl
2878 itself creates after parsing a program. The output of B::Deparse won't
2879 be exactly the same as the original source, since perl doesn't keep
2880 track of comments or whitespace, and there isn't a one-to-one
2881 correspondence between perl's syntactical constructions and their
2882 compiled form, but it will often be close. When you use the B<-p>
2883 option, the output also includes parentheses even when they are not
2884 required by precedence, which can make it easy to see if perl is
2885 parsing your expressions the way you intended.
2886
2887 Please note that this module is mainly new and untested code and is
2888 still under development, so it may change in the future.
2889
2890 =head1 OPTIONS
2891
2892 As with all compiler backend options, these must follow directly after
2893 the '-MO=Deparse', separated by a comma but not any white space.
2894
2895 =over 4
2896
2897 =item B<-l>
2898
2899 Add '#line' declarations to the output based on the line and file
2900 locations of the original code.
2901
2902 =item B<-p>
2903
2904 Print extra parentheses. Without this option, B::Deparse includes
2905 parentheses in its output only when they are needed, based on the
2906 structure of your program. With B<-p>, it uses parentheses (almost)
2907 whenever they would be legal. This can be useful if you are used to
2908 LISP, or if you want to see how perl parses your input. If you say
2909
2910     if ($var & 0x7f == 65) {print "Gimme an A!"}
2911     print ($which ? $a : $b), "\n";
2912     $name = $ENV{USER} or "Bob";
2913
2914 C<B::Deparse,-p> will print
2915
2916     if (($var & 0)) {
2917         print('Gimme an A!')
2918     };
2919     (print(($which ? $a : $b)), '???');
2920     (($name = $ENV{'USER'}) or '???')
2921
2922 which probably isn't what you intended (the C<'???'> is a sign that
2923 perl optimized away a constant value).
2924
2925 =item B<-q>
2926
2927 Expand double-quoted strings into the corresponding combinations of
2928 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
2929 instance, print
2930
2931     print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
2932
2933 as
2934
2935     print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
2936           . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
2937
2938 Note that the expanded form represents the way perl handles such
2939 constructions internally -- this option actually turns off the reverse
2940 translation that B::Deparse usually does. On the other hand, note that
2941 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
2942 of $y into a string before doing the assignment.
2943
2944 =item B<-u>I<PACKAGE>
2945
2946 Normally, B::Deparse deparses the main code of a program, all the subs
2947 called by the main program (and all the subs called by them,
2948 recursively), and any other subs in the main:: package. To include
2949 subs in other packages that aren't called directly, such as AUTOLOAD,
2950 DESTROY, other subs called automatically by perl, and methods (which
2951 aren't resolved to subs until runtime), use the B<-u> option. The
2952 argument to B<-u> is the name of a package, and should follow directly
2953 after the 'u'. Multiple B<-u> options may be given, separated by
2954 commas.  Note that unlike some other backends, B::Deparse doesn't
2955 (yet) try to guess automatically when B<-u> is needed -- you must
2956 invoke it yourself.
2957
2958 =item B<-s>I<LETTERS>
2959
2960 Tweak the style of B::Deparse's output. The letters should follow
2961 directly after the 's', with no space or punctuation. The following
2962 options are available:
2963
2964 =over 4
2965
2966 =item B<C>
2967
2968 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2969
2970     if (...) {
2971          ...
2972     } else {
2973          ...
2974     }
2975
2976 instead of
2977
2978     if (...) {
2979          ...
2980     }
2981     else {
2982          ...
2983     }
2984
2985 The default is not to cuddle.
2986
2987 =item B<i>I<NUMBER>
2988
2989 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
2990
2991 =item B<T>
2992
2993 Use tabs for each 8 columns of indent. The default is to use only spaces.
2994 For instance, if the style options are B<-si4T>, a line that's indented
2995 3 times will be preceded by one tab and four spaces; if the options were
2996 B<-si8T>, the same line would be preceded by three tabs.
2997
2998 =item B<v>I<STRING>B<.>
2999
3000 Print I<STRING> for the value of a constant that can't be determined
3001 because it was optimized away (mnemonic: this happens when a constant
3002 is used in B<v>oid context). The end of the string is marked by a period.
3003 The string should be a valid perl expression, generally a constant.
3004 Note that unless it's a number, it probably needs to be quoted, and on
3005 a command line quotes need to be protected from the shell. Some
3006 conventional values include 0, 1, 42, '', 'foo', and
3007 'Useless use of constant omitted' (which may need to be
3008 B<-sv"'Useless use of constant omitted'.">
3009 or something similar depending on your shell). The default is '???'.
3010 If you're using B::Deparse on a module or other file that's require'd,
3011 you shouldn't use a value that evaluates to false, since the customary
3012 true constant at the end of a module will be in void context when the
3013 file is compiled as a main program.
3014
3015 =back
3016
3017 =item B<-x>I<LEVEL>
3018
3019 Expand conventional syntax constructions into equivalent ones that expose
3020 their internal operation. I<LEVEL> should be a digit, with higher values
3021 meaning more expansion. As with B<-q>, this actually involves turning off
3022 special cases in B::Deparse's normal operations.
3023
3024 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3025 while loops with continue blocks; for instance
3026
3027     for ($i = 0; $i < 10; ++$i) {
3028         print $i;
3029     }
3030
3031 turns into
3032
3033     $i = 0;
3034     while ($i < 10) {
3035         print $i;
3036     } continue {
3037         ++$i
3038     }
3039
3040 Note that in a few cases this translation can't be perfectly carried back
3041 into the source code -- if the loop's initializer declares a my variable,
3042 for instance, it won't have the correct scope outside of the loop.
3043
3044 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3045 expressions using C<&&>, C<?:> and C<do {}>; for instance
3046
3047     print 'hi' if $nice;
3048     if ($nice) {
3049         print 'hi';
3050     }
3051     if ($nice) {
3052         print 'hi';
3053     } else {
3054         print 'bye';
3055     }
3056
3057 turns into
3058
3059     $nice and print 'hi';
3060     $nice and do { print 'hi' };
3061     $nice ? do { print 'hi' } : do { print 'bye' };
3062
3063 Long sequences of elsifs will turn into nested ternary operators, which
3064 B::Deparse doesn't know how to indent nicely.
3065
3066 =back
3067
3068 =head1 USING B::Deparse AS A MODULE
3069
3070 =head2 Synopsis
3071
3072     use B::Deparse;
3073     $deparse = B::Deparse->new("-p", "-sC");
3074     $body = $deparse->coderef2text(\&func);
3075     eval "sub func $body"; # the inverse operation
3076
3077 =head2 Description
3078
3079 B::Deparse can also be used on a sub-by-sub basis from other perl
3080 programs.
3081
3082 =head2 new
3083
3084     $deparse = B::Deparse->new(OPTIONS)
3085
3086 Create an object to store the state of a deparsing operation and any
3087 options. The options are the same as those that can be given on the
3088 command line (see L</OPTIONS>); options that are separated by commas
3089 after B<-MO=Deparse> should be given as separate strings. Some
3090 options, like B<-u>, don't make sense for a single subroutine, so
3091 don't pass them.
3092
3093 =head2 coderef2text
3094
3095     $body = $deparse->coderef2text(\&func)
3096     $body = $deparse->coderef2text(sub ($$) { ... })
3097
3098 Return source code for the body of a subroutine (a block, optionally
3099 preceded by a prototype in parens), given a reference to the
3100 sub. Because a subroutine can have no names, or more than one name,
3101 this method doesn't return a complete subroutine definition -- if you
3102 want to eval the result, you should prepend "sub subname ", or "sub "
3103 for an anonymous function constructor. Unless the sub was defined in
3104 the main:: package, the code will include a package declaration.
3105
3106 =head1 BUGS
3107
3108 See the 'to do' list at the beginning of the module file.
3109
3110 =head1 AUTHOR
3111
3112 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
3113 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3114 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3115 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.
3116
3117 =cut