ext/B/B/Deparse.pm

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