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