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             my $sib_ppaddr = $kid->sibling->ppaddr;
 967             if ($sib_ppaddr =~ /^pp_(pad|rv2)[ah]v$/
 968                 and not $kid->sibling->flags & OPf_REF)
 969             {
 970                 # The @a in \(@a) isn't in ref context, but only when the
 971                 # parens are there.
 972                 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
 973             } elsif ($kid->sibling->ppaddr eq 'pp_entersub') {
 974                 my $text = $self->deparse($kid->sibling, 1);
 975                 # Always show parens for \(&func()), but only with -p otherwise
 976                 $text = "($text)" if $self->{'parens'}
 977                                  or $kid->sibling->private & OPpENTERSUB_AMPER;
 978                 return "\\$text";
 979             }
 980         }
 981     }
 982     $self->pfixop($op, $cx, "\\", 20);
 983 }
 984
 985 sub pp_srefgen { pp_refgen(@_) }
 986
 987 sub pp_readline {
 988     my $self = shift;
 989     my($op, $cx) = @_;
 990     my $kid = $op->first;
 991     $kid = $kid->first if $kid->ppaddr eq "pp_rv2gv"; # <$fh>
 992     return "<" . $self->deparse($kid, 1) . ">";
 993 }
 994
 995 # Unary operators that can occur as pseudo-listops inside double quotes
 996 sub dq_unop {
 997     my $self = shift;
 998     my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
 999     my $kid;
1000     if ($op->flags & OPf_KIDS) {
1001        $kid = $op->first;
1002        # If there's more than one kid, the first is an ex-pushmark.
1003        $kid = $kid->sibling if not null $kid->sibling;
1004        return $self->maybe_parens_unop($name, $kid, $cx);
1005     } else {
1006        return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");
1007     }
1008 }
1009
1010 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1011 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1012 sub pp_uc { dq_unop(@_, "uc") }
1013 sub pp_lc { dq_unop(@_, "lc") }
1014 sub pp_quotemeta { dq_unop(@_, "quotemeta") }
1015
1016 sub loopex {
1017     my $self = shift;
1018     my ($op, $cx, $name) = @_;
1019     if (class($op) eq "PVOP") {
1020         return "$name " . $op->pv;
1021     } elsif (class($op) eq "OP") {
1022         return $name;
1023     } elsif (class($op) eq "UNOP") {
1024         # Note -- loop exits are actually exempt from the
1025         # looks-like-a-func rule, but a few extra parens won't hurt
1026         return $self->maybe_parens_unop($name, $op->first, $cx);
1027     }
1028 }
1029
1030 sub pp_last { loopex(@_, "last") }
1031 sub pp_next { loopex(@_, "next") }
1032 sub pp_redo { loopex(@_, "redo") }
1033 sub pp_goto { loopex(@_, "goto") }
1034 sub pp_dump { loopex(@_, "dump") }
1035
1036 sub ftst {
1037     my $self = shift;
1038     my($op, $cx, $name) = @_;
1039     if (class($op) eq "UNOP") {
1040         # Genuine `-X' filetests are exempt from the LLAFR, but not
1041         # l?stat(); for the sake of clarity, give'em all parens
1042         return $self->maybe_parens_unop($name, $op->first, $cx);
1043     } elsif (class($op) eq "GVOP") {
1044         return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1045     } else { # I don't think baseop filetests ever survive ck_ftst, but...
1046         return $name;
1047     }
1048 }
1049
1050 sub pp_lstat { ftst(@_, "lstat") }
1051 sub pp_stat { ftst(@_, "stat") }
1052 sub pp_ftrread { ftst(@_, "-R") }
1053 sub pp_ftrwrite { ftst(@_, "-W") }
1054 sub pp_ftrexec { ftst(@_, "-X") }
1055 sub pp_fteread { ftst(@_, "-r") }
1056 sub pp_ftewrite { ftst(@_, "-r") }
1057 sub pp_fteexec { ftst(@_, "-r") }
1058 sub pp_ftis { ftst(@_, "-e") }
1059 sub pp_fteowned { ftst(@_, "-O") }
1060 sub pp_ftrowned { ftst(@_, "-o") }
1061 sub pp_ftzero { ftst(@_, "-z") }
1062 sub pp_ftsize { ftst(@_, "-s") }
1063 sub pp_ftmtime { ftst(@_, "-M") }
1064 sub pp_ftatime { ftst(@_, "-A") }
1065 sub pp_ftctime { ftst(@_, "-C") }
1066 sub pp_ftsock { ftst(@_, "-S") }
1067 sub pp_ftchr { ftst(@_, "-c") }
1068 sub pp_ftblk { ftst(@_, "-b") }
1069 sub pp_ftfile { ftst(@_, "-f") }
1070 sub pp_ftdir { ftst(@_, "-d") }
1071 sub pp_ftpipe { ftst(@_, "-p") }
1072 sub pp_ftlink { ftst(@_, "-l") }
1073 sub pp_ftsuid { ftst(@_, "-u") }
1074 sub pp_ftsgid { ftst(@_, "-g") }
1075 sub pp_ftsvtx { ftst(@_, "-k") }
1076 sub pp_fttty { ftst(@_, "-t") }
1077 sub pp_fttext { ftst(@_, "-T") }
1078 sub pp_ftbinary { ftst(@_, "-B") }
1079
1080 sub SWAP_CHILDREN () { 1 }
1081 sub ASSIGN () { 2 } # has OP= variant
1082
1083 my(%left, %right);
1084
1085 sub assoc_class {
1086     my $op = shift;
1087     my $name = $op->ppaddr;
1088     if ($name eq "pp_concat" and $op->first->ppaddr eq "pp_concat") {
1089         # avoid spurious `=' -- see comment in pp_concat
1090         return "pp_concat";
1091     }
1092     if ($name eq "pp_null" and class($op) eq "UNOP"
1093         and $op->first->ppaddr =~ /^pp_(and|x?or)$/
1094         and null $op->first->sibling)
1095     {
1096         # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1097         # with a null that's used as the common end point of the two
1098         # flows of control. For precedence purposes, ignore it.
1099         # (COND_EXPRs have these too, but we don't bother with
1100         # their associativity).
1101         return assoc_class($op->first);
1102     }
1103     return $name . ($op->flags & OPf_STACKED ? "=" : "");
1104 }
1105
1106 # Left associative operators, like `+', for which
1107 # $a + $b + $c is equivalent to ($a + $b) + $c
1108
1109 BEGIN {
1110     %left = ('pp_multiply' => 19, 'pp_i_multiply' => 19,
1111              'pp_divide' => 19, 'pp_i_divide' => 19,
1112              'pp_modulo' => 19, 'pp_i_modulo' => 19,
1113              'pp_repeat' => 19,
1114              'pp_add' => 18, 'pp_i_add' => 18,
1115              'pp_subtract' => 18, 'pp_i_subtract' => 18,
1116              'pp_concat' => 18,
1117              'pp_left_shift' => 17, 'pp_right_shift' => 17,
1118              'pp_bit_and' => 13,
1119              'pp_bit_or' => 12, 'pp_bit_xor' => 12,
1120              'pp_and' => 3,
1121              'pp_or' => 2, 'pp_xor' => 2,
1122             );
1123 }
1124
1125 sub deparse_binop_left {
1126     my $self = shift;
1127     my($op, $left, $prec) = @_;
1128     if ($left{assoc_class($op)}
1129         and $left{assoc_class($op)} == $left{assoc_class($left)})
1130     {
1131         return $self->deparse($left, $prec - .00001);
1132     } else {
1133         return $self->deparse($left, $prec);
1134     }
1135 }
1136
1137 # Right associative operators, like `=', for which
1138 # $a = $b = $c is equivalent to $a = ($b = $c)
1139
1140 BEGIN {
1141     %right = ('pp_pow' => 22,
1142               'pp_sassign=' => 7, 'pp_aassign=' => 7,
1143               'pp_multiply=' => 7, 'pp_i_multiply=' => 7,
1144               'pp_divide=' => 7, 'pp_i_divide=' => 7,
1145               'pp_modulo=' => 7, 'pp_i_modulo=' => 7,
1146               'pp_repeat=' => 7,
1147               'pp_add=' => 7, 'pp_i_add=' => 7,
1148               'pp_subtract=' => 7, 'pp_i_subtract=' => 7,
1149               'pp_concat=' => 7,
1150               'pp_left_shift=' => 7, 'pp_right_shift=' => 7,
1151               'pp_bit_and=' => 7,
1152               'pp_bit_or=' => 7, 'pp_bit_xor=' => 7,
1153               'pp_andassign' => 7,
1154               'pp_orassign' => 7,
1155              );
1156 }
1157
1158 sub deparse_binop_right {
1159     my $self = shift;
1160     my($op, $right, $prec) = @_;
1161     if ($right{assoc_class($op)}
1162         and $right{assoc_class($op)} == $right{assoc_class($right)})
1163     {
1164         return $self->deparse($right, $prec - .00001);
1165     } else {
1166         return $self->deparse($right, $prec);
1167     }
1168 }
1169
1170 sub binop {
1171     my $self = shift;
1172     my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1173     my $left = $op->first;
1174     my $right = $op->last;
1175     my $eq = "";
1176     if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1177         $eq = "=";
1178         $prec = 7;
1179     }
1180     if ($flags & SWAP_CHILDREN) {
1181         ($left, $right) = ($right, $left);
1182     }
1183     $left = $self->deparse_binop_left($op, $left, $prec);
1184     $right = $self->deparse_binop_right($op, $right, $prec);
1185     return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1186 }
1187
1188 sub pp_add { binop(@_, "+", 18, ASSIGN) }
1189 sub pp_multiply { binop(@_, "*", 19, ASSIGN) }
1190 sub pp_subtract { binop(@_, "-",18,  ASSIGN) }
1191 sub pp_divide { binop(@_, "/", 19, ASSIGN) }
1192 sub pp_modulo { binop(@_, "%", 19, ASSIGN) }
1193 sub pp_i_add { binop(@_, "+", 18, ASSIGN) }
1194 sub pp_i_multiply { binop(@_, "*", 19, ASSIGN) }
1195 sub pp_i_subtract { binop(@_, "-", 18, ASSIGN) }
1196 sub pp_i_divide { binop(@_, "/", 19, ASSIGN) }
1197 sub pp_i_modulo { binop(@_, "%", 19, ASSIGN) }
1198 sub pp_pow { binop(@_, "**", 22, ASSIGN) }
1199
1200 sub pp_left_shift { binop(@_, "<<", 17, ASSIGN) }
1201 sub pp_right_shift { binop(@_, ">>", 17, ASSIGN) }
1202 sub pp_bit_and { binop(@_, "&", 13, ASSIGN) }
1203 sub pp_bit_or { binop(@_, "|", 12, ASSIGN) }
1204 sub pp_bit_xor { binop(@_, "^", 12, ASSIGN) }
1205
1206 sub pp_eq { binop(@_, "==", 14) }
1207 sub pp_ne { binop(@_, "!=", 14) }
1208 sub pp_lt { binop(@_, "<", 15) }
1209 sub pp_gt { binop(@_, ">", 15) }
1210 sub pp_ge { binop(@_, ">=", 15) }
1211 sub pp_le { binop(@_, "<=", 15) }
1212 sub pp_ncmp { binop(@_, "<=>", 14) }
1213 sub pp_i_eq { binop(@_, "==", 14) }
1214 sub pp_i_ne { binop(@_, "!=", 14) }
1215 sub pp_i_lt { binop(@_, "<", 15) }
1216 sub pp_i_gt { binop(@_, ">", 15) }
1217 sub pp_i_ge { binop(@_, ">=", 15) }
1218 sub pp_i_le { binop(@_, "<=", 15) }
1219 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1220
1221 sub pp_seq { binop(@_, "eq", 14) }
1222 sub pp_sne { binop(@_, "ne", 14) }
1223 sub pp_slt { binop(@_, "lt", 15) }
1224 sub pp_sgt { binop(@_, "gt", 15) }
1225 sub pp_sge { binop(@_, "ge", 15) }
1226 sub pp_sle { binop(@_, "le", 15) }
1227 sub pp_scmp { binop(@_, "cmp", 14) }
1228
1229 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1230 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1231
1232 # `.' is special because concats-of-concats are optimized to save copying
1233 # by making all but the first concat stacked. The effect is as if the
1234 # programmer had written `($a . $b) .= $c', except legal.
1235 sub pp_concat {
1236     my $self = shift;
1237     my($op, $cx) = @_;
1238     my $left = $op->first;
1239     my $right = $op->last;
1240     my $eq = "";
1241     my $prec = 18;
1242     if ($op->flags & OPf_STACKED and $op->first->ppaddr ne "pp_concat") {
1243         $eq = "=";
1244         $prec = 7;
1245     }
1246     $left = $self->deparse_binop_left($op, $left, $prec);
1247     $right = $self->deparse_binop_right($op, $right, $prec);
1248     return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1249 }
1250
1251 # `x' is weird when the left arg is a list
1252 sub pp_repeat {
1253     my $self = shift;
1254     my($op, $cx) = @_;
1255     my $left = $op->first;
1256     my $right = $op->last;
1257     my $eq = "";
1258     my $prec = 19;
1259     if ($op->flags & OPf_STACKED) {
1260         $eq = "=";
1261         $prec = 7;
1262     }
1263     if (null($right)) { # list repeat; count is inside left-side ex-list
1264         my $kid = $left->first->sibling; # skip pushmark
1265         my @exprs;
1266         for (; !null($kid->sibling); $kid = $kid->sibling) {
1267             push @exprs, $self->deparse($kid, 6);
1268         }
1269         $right = $kid;
1270         $left = "(" . join(", ", @exprs). ")";
1271     } else {
1272         $left = $self->deparse_binop_left($op, $left, $prec);
1273     }
1274     $right = $self->deparse_binop_right($op, $right, $prec);
1275     return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1276 }
1277
1278 sub range {
1279     my $self = shift;
1280     my ($op, $cx, $type) = @_;
1281     my $left = $op->first;
1282     my $right = $left->sibling;
1283     $left = $self->deparse($left, 9);
1284     $right = $self->deparse($right, 9);
1285     return $self->maybe_parens("$left $type $right", $cx, 9);
1286 }
1287
1288 sub pp_flop {
1289     my $self = shift;
1290     my($op, $cx) = @_;
1291     my $flip = $op->first;
1292     my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1293     return $self->range($flip->first, $cx, $type);
1294 }
1295
1296 # one-line while/until is handled in pp_leave
1297
1298 sub logop {
1299     my $self = shift;
1300     my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1301     my $left = $op->first;
1302     my $right = $op->first->sibling;
1303     if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
1304         $left = $self->deparse($left, 1);
1305         $right = $self->deparse($right, 0);
1306         return "$blockname ($left) {\n\t$right\n\b}\cK";
1307     } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
1308         $right = $self->deparse($right, 1);
1309         $left = $self->deparse($left, 1);
1310         return "$right $blockname $left";
1311     } elsif ($cx > $lowprec and $highop) { # $a && $b
1312         $left = $self->deparse_binop_left($op, $left, $highprec);
1313         $right = $self->deparse_binop_right($op, $right, $highprec);
1314         return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1315     } else { # $a and $b
1316         $left = $self->deparse_binop_left($op, $left, $lowprec);
1317         $right = $self->deparse_binop_right($op, $right, $lowprec);
1318         return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1319     }
1320 }
1321
1322 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1323 sub pp_or {  logop(@_, "or",  2, "||", 10, "unless") }
1324 sub pp_xor { logop(@_, "xor", 2, "",   0,  "") }
1325
1326 sub logassignop {
1327     my $self = shift;
1328     my ($op, $cx, $opname) = @_;
1329     my $left = $op->first;
1330     my $right = $op->first->sibling->first; # skip sassign
1331     $left = $self->deparse($left, 7);
1332     $right = $self->deparse($right, 7);
1333     return $self->maybe_parens("$left $opname $right", $cx, 7);
1334 }
1335
1336 sub pp_andassign { logassignop(@_, "&&=") }
1337 sub pp_orassign { logassignop(@_, "||=") }
1338
1339 sub listop {
1340     my $self = shift;
1341     my($op, $cx, $name) = @_;
1342     my(@exprs);
1343     my $parens = ($cx >= 5) || $self->{'parens'};
1344     my $kid = $op->first->sibling;
1345     return $name if null $kid;
1346     my $first = $self->deparse($kid, 6);
1347     $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1348     push @exprs, $first;
1349     $kid = $kid->sibling;
1350     for (; !null($kid); $kid = $kid->sibling) {
1351         push @exprs, $self->deparse($kid, 6);
1352     }
1353     if ($parens) {
1354         return "$name(" . join(", ", @exprs) . ")";
1355     } else {
1356         return "$name " . join(", ", @exprs);
1357     }
1358 }
1359
1360 sub pp_bless { listop(@_, "bless") }
1361 sub pp_atan2 { listop(@_, "atan2") }
1362 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1363 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1364 sub pp_index { listop(@_, "index") }
1365 sub pp_rindex { listop(@_, "rindex") }
1366 sub pp_sprintf { listop(@_, "sprintf") }
1367 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1368 sub pp_crypt { listop(@_, "crypt") }
1369 sub pp_unpack { listop(@_, "unpack") }
1370 sub pp_pack { listop(@_, "pack") }
1371 sub pp_join { listop(@_, "join") }
1372 sub pp_splice { listop(@_, "splice") }
1373 sub pp_push { listop(@_, "push") }
1374 sub pp_unshift { listop(@_, "unshift") }
1375 sub pp_reverse { listop(@_, "reverse") }
1376 sub pp_warn { listop(@_, "warn") }
1377 sub pp_die { listop(@_, "die") }
1378 # Actually, return is exempt from the LLAFR (see examples in this very
1379 # module!), but for consistency's sake, ignore that fact
1380 sub pp_return { listop(@_, "return") }
1381 sub pp_open { listop(@_, "open") }
1382 sub pp_pipe_op { listop(@_, "pipe") }
1383 sub pp_tie { listop(@_, "tie") }
1384 sub pp_dbmopen { listop(@_, "dbmopen") }
1385 sub pp_sselect { listop(@_, "select") }
1386 sub pp_select { listop(@_, "select") }
1387 sub pp_read { listop(@_, "read") }
1388 sub pp_sysopen { listop(@_, "sysopen") }
1389 sub pp_sysseek { listop(@_, "sysseek") }
1390 sub pp_sysread { listop(@_, "sysread") }
1391 sub pp_syswrite { listop(@_, "syswrite") }
1392 sub pp_send { listop(@_, "send") }
1393 sub pp_recv { listop(@_, "recv") }
1394 sub pp_seek { listop(@_, "seek") }
1395 sub pp_fcntl { listop(@_, "fcntl") }
1396 sub pp_ioctl { listop(@_, "ioctl") }
1397 sub pp_flock { listop(@_, "flock") }
1398 sub pp_socket { listop(@_, "socket") }
1399 sub pp_sockpair { listop(@_, "sockpair") }
1400 sub pp_bind { listop(@_, "bind") }
1401 sub pp_connect { listop(@_, "connect") }
1402 sub pp_listen { listop(@_, "listen") }
1403 sub pp_accept { listop(@_, "accept") }
1404 sub pp_shutdown { listop(@_, "shutdown") }
1405 sub pp_gsockopt { listop(@_, "getsockopt") }
1406 sub pp_ssockopt { listop(@_, "setsockopt") }
1407 sub pp_chown { listop(@_, "chown") }
1408 sub pp_unlink { listop(@_, "unlink") }
1409 sub pp_chmod { listop(@_, "chmod") }
1410 sub pp_utime { listop(@_, "utime") }
1411 sub pp_rename { listop(@_, "rename") }
1412 sub pp_link { listop(@_, "link") }
1413 sub pp_symlink { listop(@_, "symlink") }
1414 sub pp_mkdir { listop(@_, "mkdir") }
1415 sub pp_open_dir { listop(@_, "opendir") }
1416 sub pp_seekdir { listop(@_, "seekdir") }
1417 sub pp_waitpid { listop(@_, "waitpid") }
1418 sub pp_system { listop(@_, "system") }
1419 sub pp_exec { listop(@_, "exec") }
1420 sub pp_kill { listop(@_, "kill") }
1421 sub pp_setpgrp { listop(@_, "setpgrp") }
1422 sub pp_getpriority { listop(@_, "getpriority") }
1423 sub pp_setpriority { listop(@_, "setpriority") }
1424 sub pp_shmget { listop(@_, "shmget") }
1425 sub pp_shmctl { listop(@_, "shmctl") }
1426 sub pp_shmread { listop(@_, "shmread") }
1427 sub pp_shmwrite { listop(@_, "shmwrite") }
1428 sub pp_msgget { listop(@_, "msgget") }
1429 sub pp_msgctl { listop(@_, "msgctl") }
1430 sub pp_msgsnd { listop(@_, "msgsnd") }
1431 sub pp_msgrcv { listop(@_, "msgrcv") }
1432 sub pp_semget { listop(@_, "semget") }
1433 sub pp_semctl { listop(@_, "semctl") }
1434 sub pp_semop { listop(@_, "semop") }
1435 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1436 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1437 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1438 sub pp_gsbyname { listop(@_, "getservbyname") }
1439 sub pp_gsbyport { listop(@_, "getservbyport") }
1440 sub pp_syscall { listop(@_, "syscall") }
1441
1442 sub pp_glob {
1443     my $self = shift;
1444     my($op, $cx) = @_;
1445     my $text = $self->dq($op->first->sibling);  # skip pushmark
1446     if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1447         or $text =~ /[<>]/) {
1448         return 'glob(' . single_delim('qq', '"', $text) . ')';
1449     } else {
1450         return '<' . $text . '>';
1451     }
1452 }
1453
1454 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1455 # be a filehandle. This could probably be better fixed in the core
1456 # by moving the GV lookup into ck_truc.
1457
1458 sub pp_truncate {
1459     my $self = shift;
1460     my($op, $cx) = @_;
1461     my(@exprs);
1462     my $parens = ($cx >= 5) || $self->{'parens'};
1463     my $kid = $op->first->sibling;
1464     my $fh;
1465     if ($op->flags & OPf_SPECIAL) {
1466         # $kid is an OP_CONST
1467         $fh = $kid->sv->PV;
1468     } else {
1469         $fh = $self->deparse($kid, 6);
1470         $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1471     }
1472     my $len = $self->deparse($kid->sibling, 6);
1473     if ($parens) {
1474         return "truncate($fh, $len)";
1475     } else {
1476         return "truncate $fh, $len";
1477     }
1478 }
1479
1480 sub indirop {
1481     my $self = shift;
1482     my($op, $cx, $name) = @_;
1483     my($expr, @exprs);
1484     my $kid = $op->first->sibling;
1485     my $indir = "";
1486     if ($op->flags & OPf_STACKED) {
1487         $indir = $kid;
1488         $indir = $indir->first; # skip rv2gv
1489         if (is_scope($indir)) {
1490             $indir = "{" . $self->deparse($indir, 0) . "}";
1491         } else {
1492             $indir = $self->deparse($indir, 24);
1493         }
1494         $indir = $indir . " ";
1495         $kid = $kid->sibling;
1496     }
1497     for (; !null($kid); $kid = $kid->sibling) {
1498         $expr = $self->deparse($kid, 6);
1499         push @exprs, $expr;
1500     }
1501     return $self->maybe_parens_func($name,
1502                                     $indir . join(", ", @exprs),
1503                                     $cx, 5);
1504 }
1505
1506 sub pp_prtf { indirop(@_, "printf") }
1507 sub pp_print { indirop(@_, "print") }
1508 sub pp_sort { indirop(@_, "sort") }
1509
1510 sub mapop {
1511     my $self = shift;
1512     my($op, $cx, $name) = @_;
1513     my($expr, @exprs);
1514     my $kid = $op->first; # this is the (map|grep)start
1515     $kid = $kid->first->sibling; # skip a pushmark
1516     my $code = $kid->first; # skip a null
1517     if (is_scope $code) {
1518         $code = "{" . $self->deparse($code, 1) . "} ";
1519     } else {
1520         $code = $self->deparse($code, 24) . ", ";
1521     }
1522     $kid = $kid->sibling;
1523     for (; !null($kid); $kid = $kid->sibling) {
1524         $expr = $self->deparse($kid, 6);
1525         push @exprs, $expr if $expr;
1526     }
1527     return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1528 }
1529
1530 sub pp_mapwhile { mapop(@_, "map") }
1531 sub pp_grepwhile { mapop(@_, "grep") }
1532
1533 sub pp_list {
1534     my $self = shift;
1535     my($op, $cx) = @_;
1536     my($expr, @exprs);
1537     my $kid = $op->first->sibling; # skip pushmark
1538     my $lop;
1539     my $local = "either"; # could be local(...) or my(...)
1540     for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1541         # This assumes that no other private flags equal 128, and that
1542         # OPs that store things other than flags in their op_private,
1543         # like OP_AELEMFAST, won't be immediate children of a list.
1544         unless ($lop->private & OPpLVAL_INTRO or $lop->ppaddr eq "pp_undef")
1545         {
1546             $local = ""; # or not
1547             last;
1548         }
1549         if ($lop->ppaddr =~ /^pp_pad[ash]v$/) { # my()
1550             ($local = "", last) if $local eq "local";
1551             $local = "my";
1552         } elsif ($lop->ppaddr ne "pp_undef") { # local()
1553             ($local = "", last) if $local eq "my";
1554             $local = "local";
1555         }
1556     }
1557     $local = "" if $local eq "either"; # no point if it's all undefs
1558     return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
1559     for (; !null($kid); $kid = $kid->sibling) {
1560         if ($local) {
1561             if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") {
1562                 $lop = $kid->first;
1563             } else {
1564                 $lop = $kid;
1565             }
1566             $self->{'avoid_local'}{$$lop}++;
1567             $expr = $self->deparse($kid, 6);
1568             delete $self->{'avoid_local'}{$$lop};
1569         } else {
1570             $expr = $self->deparse($kid, 6);
1571         }
1572         push @exprs, $expr;
1573     }
1574     if ($local) {
1575         return "$local(" . join(", ", @exprs) . ")";
1576     } else {
1577         return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1578     }
1579 }
1580
1581 sub pp_cond_expr {
1582     my $self = shift;
1583     my($op, $cx) = @_;
1584     my $cond = $op->first;
1585     my $true = $cond->sibling;
1586     my $false = $true->sibling;
1587     my $cuddle = $self->{'cuddle'};
1588     unless ($cx == 0 and is_scope($true) and is_scope($false)) {
1589         $cond = $self->deparse($cond, 8);
1590         $true = $self->deparse($true, 8);
1591         $false = $self->deparse($false, 8);
1592         return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1593     }
1594     $cond = $self->deparse($cond, 1);
1595     $true = $self->deparse($true, 0);
1596     if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif
1597         my $head = "if ($cond) {\n\t$true\n\b}";
1598         my @elsifs;
1599         while (!null($false) and $false->ppaddr eq "pp_lineseq") {
1600             my $newop = $false->first->sibling->first;
1601             my $newcond = $newop->first;
1602             my $newtrue = $newcond->sibling;
1603             $false = $newtrue->sibling; # last in chain is OP_AND => no else
1604             $newcond = $self->deparse($newcond, 1);
1605             $newtrue = $self->deparse($newtrue, 0);
1606             push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1607         }
1608         if (!null($false)) {
1609             $false = $cuddle . "else {\n\t" .
1610               $self->deparse($false, 0) . "\n\b}\cK";
1611         } else {
1612             $false = "\cK";
1613         }
1614         return $head . join($cuddle, "", @elsifs) . $false;
1615     }
1616     $false = $self->deparse($false, 0);
1617     return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK";
1618 }
1619
1620 sub pp_leaveloop {
1621     my $self = shift;
1622     my($op, $cx) = @_;
1623     my $enter = $op->first;
1624     my $kid = $enter->sibling;
1625     local($self->{'curstash'}) = $self->{'curstash'};
1626     my $head = "";
1627     my $bare = 0;
1628     if ($kid->ppaddr eq "pp_lineseq") { # bare or infinite loop
1629         if (is_state $kid->last) { # infinite
1630             $head = "for (;;) "; # shorter than while (1)
1631         } else {
1632             $bare = 1;
1633         }
1634     } elsif ($enter->ppaddr eq "pp_enteriter") { # foreach
1635         my $ary = $enter->first->sibling; # first was pushmark
1636         my $var = $ary->sibling;
1637         if ($enter->flags & OPf_STACKED
1638             and not null $ary->first->sibling->sibling)
1639         {
1640             $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1641               $self->deparse($ary->first->sibling->sibling, 9);
1642         } else {
1643             $ary = $self->deparse($ary, 1);
1644         }
1645         if (null $var) {
1646             if ($enter->flags & OPf_SPECIAL) { # thread special var
1647                 $var = $self->pp_threadsv($enter, 1);
1648             } else { # regular my() variable
1649                 $var = $self->pp_padsv($enter, 1);
1650                 if ($self->padname_sv($enter->targ)->IVX ==
1651                     $kid->first->first->sibling->last->cop_seq)
1652                 {
1653                     # If the scope of this variable closes at the last
1654                     # statement of the loop, it must have been
1655                     # declared here.
1656                     $var = "my " . $var;
1657                 }
1658             }
1659         } elsif ($var->ppaddr eq "pp_rv2gv") {
1660             $var = $self->pp_rv2sv($var, 1);
1661         } elsif ($var->ppaddr eq "pp_gv") {
1662             $var = "\$" . $self->deparse($var, 1);
1663         }
1664         $head = "foreach $var ($ary) ";
1665         $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1666     } elsif ($kid->ppaddr eq "pp_null") { # while/until
1667         $kid = $kid->first;
1668         my $name = {"pp_and" => "while", "pp_or" => "until"}
1669                     ->{$kid->ppaddr};
1670         $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
1671         $kid = $kid->first->sibling;
1672     } elsif ($kid->ppaddr eq "pp_stub") { # bare and empty
1673         return "{;}"; # {} could be a hashref
1674     }
1675     # The third-to-last kid is the continue block if the pointer used
1676     # by `next BLOCK' points to its first OP, which happens to be the
1677     # the op_next of the head of the _previous_ statement.
1678     # Unless it's a bare loop, in which case it's last, since there's
1679     # no unstack or extra nextstate.
1680     # Except if the previous head isn't null but the first kid is
1681     # (because it's a nulled out nextstate in a scope), in which
1682     # case the head's next is advanced past the null but the nextop's
1683     # isn't, so we need to try nextop->next.
1684     my $precont;
1685     my $cont = $kid->first;
1686     if ($bare) {
1687         while (!null($cont->sibling)) {
1688             $precont = $cont;
1689             $cont = $cont->sibling;
1690         }
1691     } else {
1692         while (!null($cont->sibling->sibling->sibling)) {
1693             $precont = $cont;
1694             $cont = $cont->sibling;
1695         }
1696     }
1697     if ($precont and $ {$precont->next} == $ {$enter->nextop}
1698         || $ {$precont->next} == $ {$enter->nextop->next} )
1699     {
1700        my $state = $kid->first;
1701        my $cuddle = $self->{'cuddle'};
1702        my($expr, @exprs);
1703        for (; $$state != $$cont; $state = $state->sibling) {
1704            $expr = "";
1705            if (is_state $state) {
1706                $expr = $self->deparse($state, 0);
1707                $state = $state->sibling;
1708                last if null $kid;
1709            }
1710            $expr .= $self->deparse($state, 0);
1711            push @exprs, $expr if $expr;
1712        }
1713        $kid = join(";\n", @exprs);
1714        $cont = $cuddle . "continue {\n\t" .
1715          $self->deparse($cont, 0) . "\n\b}\cK";
1716     } else {
1717         $cont = "\cK";
1718         $kid = $self->deparse($kid, 0);
1719     }
1720     return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1721 }
1722
1723 sub pp_leavetry {
1724     my $self = shift;
1725     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
1726 }
1727
1728 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
1729 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
1730
1731 sub pp_null {
1732     my $self = shift;
1733     my($op, $cx) = @_;
1734     if (class($op) eq "OP") {
1735         return "'???'" if $op->targ == OP_CONST; # old value is lost
1736     } elsif ($op->first->ppaddr eq "pp_pushmark") {
1737         return $self->pp_list($op, $cx);
1738     } elsif ($op->first->ppaddr eq "pp_enter") {
1739         return $self->pp_leave($op, $cx);
1740     } elsif ($op->targ == OP_STRINGIFY) {
1741         return $self->dquote($op);
1742     } elsif (!null($op->first->sibling) and
1743              $op->first->sibling->ppaddr eq "pp_readline" and
1744              $op->first->sibling->flags & OPf_STACKED) {
1745         return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1746                                    . $self->deparse($op->first->sibling, 7),
1747                                    $cx, 7);
1748     } elsif (!null($op->first->sibling) and
1749              $op->first->sibling->ppaddr eq "pp_trans" and
1750              $op->first->sibling->flags & OPf_STACKED) {
1751         return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1752                                    . $self->deparse($op->first->sibling, 20),
1753                                    $cx, 20);
1754     } else {
1755         return $self->deparse($op->first, $cx);
1756     }
1757 }
1758
1759 # the aassign in-common check messes up SvCUR (always setting it
1760 # to a value >= 100), but it's probably safe to assume there
1761 # won't be any NULs in the names of my() variables. (with
1762 # stash variables, I wouldn't be so sure)
1763 sub padname_fix {
1764     my $str = shift;
1765     $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
1766     return $str;
1767 }
1768
1769 sub padname {
1770     my $self = shift;
1771     my $targ = shift;
1772     my $str = $self->padname_sv($targ)->PV;
1773     return padname_fix($str);
1774 }
1775
1776 sub padany {
1777     my $self = shift;
1778     my $op = shift;
1779     return substr($self->padname($op->targ), 1); # skip $/@/%
1780 }
1781
1782 sub pp_padsv {
1783     my $self = shift;
1784     my($op, $cx) = @_;
1785     return $self->maybe_my($op, $cx, $self->padname($op->targ));
1786 }
1787
1788 sub pp_padav { pp_padsv(@_) }
1789 sub pp_padhv { pp_padsv(@_) }
1790
1791 my @threadsv_names;
1792
1793 BEGIN {
1794     @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1795                        "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1796                        "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1797                        "!", "@");
1798 }
1799
1800 sub pp_threadsv {
1801     my $self = shift;
1802     my($op, $cx) = @_;
1803     return $self->maybe_local($op, $cx, "\$" .  $threadsv_names[$op->targ]);
1804 }
1805
1806 sub pp_gvsv {
1807     my $self = shift;
1808     my($op, $cx) = @_;
1809     return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
1810 }
1811
1812 sub pp_gv {
1813     my $self = shift;
1814     my($op, $cx) = @_;
1815     return $self->gv_name($op->gv);
1816 }
1817
1818 sub pp_aelemfast {
1819     my $self = shift;
1820     my($op, $cx) = @_;
1821     my $gv = $op->gv;
1822     return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1823 }
1824
1825 sub rv2x {
1826     my $self = shift;
1827     my($op, $cx, $type) = @_;
1828     my $kid = $op->first;
1829     my $str = $self->deparse($kid, 0);
1830     return $type . (is_scalar($kid) ? $str : "{$str}");
1831 }
1832
1833 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1834 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1835 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1836
1837 # skip rv2av
1838 sub pp_av2arylen {
1839     my $self = shift;
1840     my($op, $cx) = @_;
1841     if ($op->first->ppaddr eq "pp_padav") {
1842         return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
1843     } else {
1844         return $self->maybe_local($op, $cx,
1845                                   $self->rv2x($op->first, $cx, '$#'));
1846     }
1847 }
1848
1849 # skip down to the old, ex-rv2cv
1850 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
1851
1852 sub pp_rv2av {
1853     my $self = shift;
1854     my($op, $cx) = @_;
1855     my $kid = $op->first;
1856     if ($kid->ppaddr eq "pp_const") { # constant list
1857         my $av = $kid->sv;
1858         return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1859     } else {
1860         return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
1861     }
1862  }
1863
1864
1865 sub elem {
1866     my $self = shift;
1867     my ($op, $cx, $left, $right, $padname) = @_;
1868     my($array, $idx) = ($op->first, $op->first->sibling);
1869     unless ($array->ppaddr eq $padname) { # Maybe this has been fixed
1870         $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1871     }
1872     if ($array->ppaddr eq $padname) {
1873         $array = $self->padany($array);
1874     } elsif (is_scope($array)) { # ${expr}[0]
1875         $array = "{" . $self->deparse($array, 0) . "}";
1876     } elsif (is_scalar $array) { # $x[0], $$x[0], ...
1877         $array = $self->deparse($array, 24);
1878     } else {
1879         # $x[20][3]{hi} or expr->[20]
1880         my $arrow;
1881         $arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/;
1882         return $self->deparse($array, 24) . $arrow .
1883             $left . $self->deparse($idx, 1) . $right;
1884     }
1885     $idx = $self->deparse($idx, 1);
1886     return "\$" . $array . $left . $idx . $right;
1887 }
1888
1889 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) }
1890 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) }
1891
1892 sub pp_gelem {
1893     my $self = shift;
1894     my($op, $cx) = @_;
1895     my($glob, $part) = ($op->first, $op->last);
1896     $glob = $glob->first; # skip rv2gv
1897     $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug
1898     my $scope = is_scope($glob);
1899     $glob = $self->deparse($glob, 0);
1900     $part = $self->deparse($part, 1);
1901     return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
1902 }
1903
1904 sub slice {
1905     my $self = shift;
1906     my ($op, $cx, $left, $right, $regname, $padname) = @_;
1907     my $last;
1908     my(@elems, $kid, $array, $list);
1909     if (class($op) eq "LISTOP") {
1910         $last = $op->last;
1911     } else { # ex-hslice inside delete()
1912         for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
1913         $last = $kid;
1914     }
1915     $array = $last;
1916     $array = $array->first
1917         if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null";
1918     if (is_scope($array)) {
1919         $array = "{" . $self->deparse($array, 0) . "}";
1920     } elsif ($array->ppaddr eq $padname) {
1921         $array = $self->padany($array);
1922     } else {
1923         $array = $self->deparse($array, 24);
1924     }
1925     $kid = $op->first->sibling; # skip pushmark
1926     if ($kid->ppaddr eq "pp_list") {
1927         $kid = $kid->first->sibling; # skip list, pushmark
1928         for (; !null $kid; $kid = $kid->sibling) {
1929             push @elems, $self->deparse($kid, 6);
1930         }
1931         $list = join(", ", @elems);
1932     } else {
1933         $list = $self->deparse($kid, 1);
1934     }
1935     return "\@" . $array . $left . $list . $right;
1936 }
1937
1938 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]",
1939                                       "pp_rv2av", "pp_padav")) }
1940 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}",
1941                                       "pp_rv2hv", "pp_padhv")) }
1942
1943 sub pp_lslice {
1944     my $self = shift;
1945     my($op, $cx) = @_;
1946     my $idx = $op->first;
1947     my $list = $op->last;
1948     my(@elems, $kid);
1949     $list = $self->deparse($list, 1);
1950     $idx = $self->deparse($idx, 1);
1951     return "($list)" . "[$idx]";
1952 }
1953
1954 sub want_scalar {
1955     my $op = shift;
1956     return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
1957 }
1958
1959 sub want_list {
1960     my $op = shift;
1961     return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
1962 }
1963
1964 sub method {
1965     my $self = shift;
1966     my($op, $cx) = @_;
1967     my $kid = $op->first->sibling; # skip pushmark
1968     my($meth, $obj, @exprs);
1969     if ($kid->ppaddr eq "pp_list" and want_list $kid) {
1970         # When an indirect object isn't a bareword but the args are in
1971         # parens, the parens aren't part of the method syntax (the LLAFR
1972         # doesn't apply), but they make a list with OPf_PARENS set that
1973         # doesn't get flattened by the append_elem that adds the method,
1974         # making a (object, arg1, arg2, ...) list where the object
1975         # usually is. This can be distinguished from
1976         # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
1977         # object) because in the later the list is in scalar context
1978         # as the left side of -> always is, while in the former
1979         # the list is in list context as method arguments always are.
1980         # (Good thing there aren't method prototypes!)
1981         $meth = $kid->sibling->first;
1982         $kid = $kid->first->sibling; # skip pushmark
1983         $obj = $kid;
1984         $kid = $kid->sibling;
1985         for (; not null $kid; $kid = $kid->sibling) {
1986             push @exprs, $self->deparse($kid, 6);
1987         }
1988     } else {
1989         $obj = $kid;
1990         $kid = $kid->sibling;
1991         for (; not null $kid->sibling; $kid = $kid->sibling) {
1992             push @exprs, $self->deparse($kid, 6);
1993         }
1994         $meth = $kid->first;
1995     }
1996     $obj = $self->deparse($obj, 24);
1997     if ($meth->ppaddr eq "pp_const") {
1998         $meth = $meth->sv->PV; # needs to be bare
1999     } else {
2000         $meth = $self->deparse($meth, 1);
2001     }
2002     my $args = join(", ", @exprs);
2003     $kid = $obj . "->" . $meth;
2004     if ($args) {
2005         return $kid . "(" . $args . ")"; # parens mandatory
2006     } else {
2007         return $kid;
2008     }
2009 }
2010
2011 # returns "&" if the prototype doesn't match the args,
2012 # or ("", $args_after_prototype_demunging) if it does.
2013 sub check_proto {
2014     my $self = shift;
2015     my($proto, @args) = @_;
2016     my($arg, $real);
2017     my $doneok = 0;
2018     my @reals;
2019     # An unbackslashed @ or % gobbles up the rest of the args
2020     $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2021     while ($proto) {
2022         $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2023         my $chr = $1;
2024         if ($chr eq "") {
2025             return "&" if @args;
2026         } elsif ($chr eq ";") {
2027             $doneok = 1;
2028         } elsif ($chr eq "@" or $chr eq "%") {
2029             push @reals, map($self->deparse($_, 6), @args);
2030             @args = ();
2031         } else {
2032             $arg = shift @args;
2033             last unless $arg;
2034             if ($chr eq "\$") {
2035                 if (want_scalar $arg) {
2036                     push @reals, $self->deparse($arg, 6);
2037                 } else {
2038                     return "&";
2039                 }
2040             } elsif ($chr eq "&") {
2041                 if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) {
2042                     push @reals, $self->deparse($arg, 6);
2043                 } else {
2044                     return "&";
2045                 }
2046             } elsif ($chr eq "*") {
2047                 if ($arg->ppaddr =~ /^pp_s?refgen$/
2048                     and $arg->first->first->ppaddr eq "pp_rv2gv")
2049                   {
2050                       $real = $arg->first->first; # skip refgen, null
2051                       if ($real->first->ppaddr eq "pp_gv") {
2052                           push @reals, $self->deparse($real, 6);
2053                       } else {
2054                           push @reals, $self->deparse($real->first, 6);
2055                       }
2056                   } else {
2057                       return "&";
2058                   }
2059             } elsif (substr($chr, 0, 1) eq "\\") {
2060                 $chr = substr($chr, 1);
2061                 if ($arg->ppaddr =~ /^pp_s?refgen$/ and
2062                     !null($real = $arg->first) and
2063                     ($chr eq "\$" && is_scalar($real->first)
2064                      or ($chr eq "\@"
2065                          && $real->first->sibling->ppaddr
2066                          =~ /^pp_(rv2|pad)av$/)
2067                      or ($chr eq "%"
2068                          && $real->first->sibling->ppaddr
2069                          =~ /^pp_(rv2|pad)hv$/)
2070                      #or ($chr eq "&" # This doesn't work
2071                      #   && $real->first->ppaddr eq "pp_rv2cv")
2072                      or ($chr eq "*"
2073                          && $real->first->ppaddr eq "pp_rv2gv")))
2074                   {
2075                       push @reals, $self->deparse($real, 6);
2076                   } else {
2077                       return "&";
2078                   }
2079             }
2080        }
2081     }
2082     return "&" if $proto and !$doneok; # too few args and no `;'
2083     return "&" if @args;               # too many args
2084     return ("", join ", ", @reals);
2085 }
2086
2087 sub pp_entersub {
2088     my $self = shift;
2089     my($op, $cx) = @_;
2090     return $self->method($op, $cx) unless null $op->first->sibling;
2091     my $prefix = "";
2092     my $amper = "";
2093     my($kid, @exprs);
2094     if ($op->flags & OPf_SPECIAL) {
2095         $prefix = "do ";
2096     } elsif ($op->private & OPpENTERSUB_AMPER) {
2097         $amper = "&";
2098     }
2099     $kid = $op->first;
2100     $kid = $kid->first->sibling; # skip ex-list, pushmark
2101     for (; not null $kid->sibling; $kid = $kid->sibling) {
2102         push @exprs, $kid;
2103     }
2104     my $simple = 0;
2105     my $proto = undef;
2106     if (is_scope($kid)) {
2107         $amper = "&";
2108         $kid = "{" . $self->deparse($kid, 0) . "}";
2109     } elsif ($kid->first->ppaddr eq "pp_gv") {
2110         my $gv = $kid->first->gv;
2111         if (class($gv->CV) ne "SPECIAL") {
2112             $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2113         }
2114         $simple = 1; # only calls of named functions can be prototyped
2115         $kid = $self->deparse($kid, 24);
2116     } elsif (is_scalar $kid->first) {
2117         $amper = "&";
2118         $kid = $self->deparse($kid, 24);
2119     } else {
2120         $prefix = "";
2121         $kid = $self->deparse($kid, 24) . "->";
2122     }
2123     my $args;
2124     if (defined $proto and not $amper) {
2125         ($amper, $args) = $self->check_proto($proto, @exprs);
2126         if ($amper eq "&") {
2127             $args = join(", ", map($self->deparse($_, 6), @exprs));
2128         }
2129     } else {
2130         $args = join(", ", map($self->deparse($_, 6), @exprs));
2131     }
2132     if ($prefix or $amper) {
2133         if ($op->flags & OPf_STACKED) {
2134             return $prefix . $amper . $kid . "(" . $args . ")";
2135         } else {
2136             return $prefix . $amper. $kid;
2137         }
2138     } else {
2139         if (defined $proto and $proto eq "") {
2140             return $kid;
2141         } elsif ($proto eq "\$") {
2142             return $self->maybe_parens_func($kid, $args, $cx, 16);
2143         } elsif ($proto or $simple) {
2144             return $self->maybe_parens_func($kid, $args, $cx, 5);
2145         } else {
2146             return "$kid(" . $args . ")";
2147         }
2148     }
2149 }
2150
2151 sub pp_enterwrite { unop(@_, "write") }
2152
2153 # escape things that cause interpolation in double quotes,
2154 # but not character escapes
2155 sub uninterp {
2156     my($str) = @_;
2157     $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2158     return $str;
2159 }
2160
2161 # the same, but treat $|, $), and $ at the end of the string differently
2162 sub re_uninterp {
2163     my($str) = @_;
2164     $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2165     $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2166     return $str;
2167 }
2168
2169 # character escapes, but not delimiters that might need to be escaped
2170 sub escape_str { # ASCII
2171     my($str) = @_;
2172     $str =~ s/\a/\\a/g;
2173 #    $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2174     $str =~ s/\t/\\t/g;
2175     $str =~ s/\n/\\n/g;
2176     $str =~ s/\e/\\e/g;
2177     $str =~ s/\f/\\f/g;
2178     $str =~ s/\r/\\r/g;
2179     $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2180     $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2181     return $str;
2182 }
2183
2184 # Don't do this for regexen
2185 sub unback {
2186     my($str) = @_;
2187     $str =~ s/\\/\\\\/g;
2188     return $str;
2189 }
2190
2191 sub balanced_delim {
2192     my($str) = @_;
2193     my @str = split //, $str;
2194     my($ar, $open, $close, $fail, $c, $cnt);
2195     for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2196         ($open, $close) = @$ar;
2197         $fail = 0; $cnt = 0;
2198         for $c (@str) {
2199             if ($c eq $open) {
2200                 $cnt++;
2201             } elsif ($c eq $close) {
2202                 $cnt--;
2203                 if ($cnt < 0) {
2204                     # qq()() isn't ")("
2205                     $fail = 1;
2206                     last;
2207                 }
2208             }
2209         }
2210         $fail = 1 if $cnt != 0;
2211         return ($open, "$open$str$close") if not $fail;
2212     }
2213     return ("", $str);
2214 }
2215
2216 sub single_delim {
2217     my($q, $default, $str) = @_;
2218     return "$default$str$default" if $default and index($str, $default) == -1;
2219     my($succeed, $delim);
2220     ($succeed, $str) = balanced_delim($str);
2221     return "$q$str" if $succeed;
2222     for $delim ('/', '"', '#') {
2223         return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2224     }
2225     if ($default) {
2226         $str =~ s/$default/\\$default/g;
2227         return "$default$str$default";
2228     } else {
2229         $str =~ s[/][\\/]g;
2230         return "$q/$str/";
2231     }
2232 }
2233
2234 sub const {
2235     my $sv = shift;
2236     if (class($sv) eq "SPECIAL") {
2237         return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2238     } elsif ($sv->FLAGS & SVf_IOK) {
2239         return $sv->IV;
2240     } elsif ($sv->FLAGS & SVf_NOK) {
2241         return $sv->NV;
2242     } elsif ($sv->FLAGS & SVf_ROK) {
2243         return "\\(" . const($sv->RV) . ")"; # constant folded
2244     } else {
2245         my $str = $sv->PV;
2246         if ($str =~ /[^ -~]/) { # ASCII for non-printing
2247             return single_delim("qq", '"', uninterp escape_str unback $str);
2248         } else {
2249             return single_delim("q", "'", unback $str);
2250         }
2251     }
2252 }
2253
2254 sub pp_const {
2255     my $self = shift;
2256     my($op, $cx) = @_;
2257 #    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2258 #       return $op->sv->PV;
2259 #    }
2260     return const($op->sv);
2261 }
2262
2263 sub dq {
2264     my $self = shift;
2265     my $op = shift;
2266     my $type = $op->ppaddr;
2267     if ($type eq "pp_const") {
2268         return uninterp(escape_str(unback($op->sv->PV)));
2269     } elsif ($type eq "pp_concat") {
2270         return $self->dq($op->first) . $self->dq($op->last);
2271     } elsif ($type eq "pp_uc") {
2272         return '\U' . $self->dq($op->first->sibling) . '\E';
2273     } elsif ($type eq "pp_lc") {
2274         return '\L' . $self->dq($op->first->sibling) . '\E';
2275     } elsif ($type eq "pp_ucfirst") {
2276         return '\u' . $self->dq($op->first->sibling);
2277     } elsif ($type eq "pp_lcfirst") {
2278         return '\l' . $self->dq($op->first->sibling);
2279     } elsif ($type eq "pp_quotemeta") {
2280         return '\Q' . $self->dq($op->first->sibling) . '\E';
2281     } elsif ($type eq "pp_join") {
2282         return $self->deparse($op->last, 26); # was join($", @ary)
2283     } else {
2284         return $self->deparse($op, 26);
2285     }
2286 }
2287
2288 sub pp_backtick {
2289     my $self = shift;
2290     my($op, $cx) = @_;
2291     # skip pushmark
2292     return single_delim("qx", '`', $self->dq($op->first->sibling));
2293 }
2294
2295 sub dquote {
2296     my $self = shift;
2297     my($op, $cx) = shift;
2298     return $self->deparse($op->first->sibling, $cx) if $self->{'unquote'};
2299     # skip ex-stringify, pushmark
2300     return single_delim("qq", '"', $self->dq($op->first->sibling));
2301 }
2302
2303 # OP_STRINGIFY is a listop, but it only ever has one arg
2304 sub pp_stringify { dquote(@_) }
2305
2306 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2307 # note that tr(from)/to/ is OK, but not tr/from/(to)
2308 sub double_delim {
2309     my($from, $to) = @_;
2310     my($succeed, $delim);
2311     if ($from !~ m[/] and $to !~ m[/]) {
2312         return "/$from/$to/";
2313     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2314         if (($succeed, $to) = balanced_delim($to) and $succeed) {
2315             return "$from$to";
2316         } else {
2317             for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2318                 return "$from$delim$to$delim" if index($to, $delim) == -1;
2319             }
2320             $to =~ s[/][\\/]g;
2321             return "$from/$to/";
2322         }
2323     } else {
2324         for $delim ('/', '"', '#') { # note no '
2325             return "$delim$from$delim$to$delim"
2326                 if index($to . $from, $delim) == -1;
2327         }
2328         $from =~ s[/][\\/]g;
2329         $to =~ s[/][\\/]g;
2330         return "/$from/$to/";
2331     }
2332 }
2333
2334 sub pchr { # ASCII
2335     my($n) = @_;
2336     if ($n == ord '\\') {
2337         return '\\\\';
2338     } elsif ($n >= ord(' ') and $n <= ord('~')) {
2339         return chr($n);
2340     } elsif ($n == ord "\a") {
2341         return '\\a';
2342     } elsif ($n == ord "\b") {
2343         return '\\b';
2344     } elsif ($n == ord "\t") {
2345         return '\\t';
2346     } elsif ($n == ord "\n") {
2347         return '\\n';
2348     } elsif ($n == ord "\e") {
2349         return '\\e';
2350     } elsif ($n == ord "\f") {
2351         return '\\f';
2352     } elsif ($n == ord "\r") {
2353         return '\\r';
2354     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2355         return '\\c' . chr(ord("@") + $n);
2356     } else {
2357 #       return '\x' . sprintf("%02x", $n);
2358         return '\\' . sprintf("%03o", $n);
2359     }
2360 }
2361
2362 sub collapse {
2363     my(@chars) = @_;
2364     my($c, $str, $tr);
2365     for ($c = 0; $c < @chars; $c++) {
2366         $tr = $chars[$c];
2367         $str .= pchr($tr);
2368         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2369             $chars[$c + 2] == $tr + 2)
2370         {
2371             for (; $c <= $#chars and $chars[$c + 1] == $chars[$c] + 1; $c++) {}
2372             $str .= "-";
2373             $str .= pchr($chars[$c]);
2374         }
2375     }
2376     return $str;
2377 }
2378
2379 sub pp_trans {
2380     my $self = shift;
2381     my($op, $cx) = @_;
2382     my(@table) = unpack("s256", $op->pv);
2383     my($c, $tr, @from, @to, @delfrom, $delhyphen);
2384     if ($table[ord "-"] != -1 and
2385         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2386     {
2387         $tr = $table[ord "-"];
2388         $table[ord "-"] = -1;
2389         if ($tr >= 0) {
2390             @from = ord("-");
2391             @to = $tr;
2392         } else { # -2 ==> delete
2393             $delhyphen = 1;
2394         }
2395     }
2396     for ($c = 0; $c < 256; $c++) {
2397         $tr = $table[$c];
2398         if ($tr >= 0) {
2399             push @from, $c; push @to, $tr;
2400         } elsif ($tr == -2) {
2401             push @delfrom, $c;
2402         }
2403     }
2404     my $flags;
2405     @from = (@from, @delfrom);
2406     if ($op->private & OPpTRANS_COMPLEMENT) {
2407         $flags .= "c";
2408         my @newfrom = ();
2409         my %from;
2410         @from{@from} = (1) x @from;
2411         for ($c = 0; $c < 256; $c++) {
2412             push @newfrom, $c unless $from{$c};
2413         }
2414         @from = @newfrom;
2415     }
2416     if ($op->private & OPpTRANS_DELETE) {
2417         $flags .= "d";
2418     } else {
2419         pop @to while $#to and $to[$#to] == $to[$#to -1];
2420     }
2421     $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2422     my($from, $to);
2423     $from = collapse(@from);
2424     $to = collapse(@to);
2425     $from .= "-" if $delhyphen;
2426     return "tr" . double_delim($from, $to) . $flags;
2427 }
2428
2429 # Like dq(), but different
2430 sub re_dq {
2431     my $self = shift;
2432     my $op = shift;
2433     my $type = $op->ppaddr;
2434     if ($type eq "pp_const") {
2435         return uninterp($op->sv->PV);
2436     } elsif ($type eq "pp_concat") {
2437         return $self->re_dq($op->first) . $self->re_dq($op->last);
2438     } elsif ($type eq "pp_uc") {
2439         return '\U' . $self->re_dq($op->first->sibling) . '\E';
2440     } elsif ($type eq "pp_lc") {
2441         return '\L' . $self->re_dq($op->first->sibling) . '\E';
2442     } elsif ($type eq "pp_ucfirst") {
2443         return '\u' . $self->re_dq($op->first->sibling);
2444     } elsif ($type eq "pp_lcfirst") {
2445         return '\l' . $self->re_dq($op->first->sibling);
2446     } elsif ($type eq "pp_quotemeta") {
2447         return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2448     } elsif ($type eq "pp_join") {
2449         return $self->deparse($op->last, 26); # was join($", @ary)
2450     } else {
2451         return $self->deparse($op, 26);
2452     }
2453 }
2454
2455 sub pp_regcomp {
2456     my $self = shift;
2457     my($op, $cx) = @_;
2458     my $kid = $op->first;
2459     $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe";
2460     $kid = $kid->first if $kid->ppaddr eq "pp_regcreset";
2461     return $self->re_dq($kid);
2462 }
2463
2464 # osmic acid -- see osmium tetroxide
2465
2466 my %matchwords;
2467 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2468     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2469     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2470
2471 sub matchop {
2472     my $self = shift;
2473     my($op, $cx, $name, $delim) = @_;
2474     my $kid = $op->first;
2475     my ($binop, $var, $re) = ("", "", "");
2476     if ($op->flags & OPf_STACKED) {
2477         $binop = 1;
2478         $var = $self->deparse($kid, 20);
2479         $kid = $kid->sibling;
2480     }
2481     if (null $kid) {
2482         $re = re_uninterp(escape_str($op->precomp));
2483     } else {
2484         $re = $self->deparse($kid, 1);
2485     }
2486     my $flags = "";
2487     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2488     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2489     $flags .= "i" if $op->pmflags & PMf_FOLD;
2490     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2491     $flags .= "o" if $op->pmflags & PMf_KEEP;
2492     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2493     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2494     $flags = $matchwords{$flags} if $matchwords{$flags};
2495     if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2496         $re =~ s/\?/\\?/g;
2497         $re = "?$re?";
2498     } else {
2499         $re = single_delim($name, $delim, $re);
2500     }
2501     $re = $re . $flags;
2502     if ($binop) {
2503         return $self->maybe_parens("$var =~ $re", $cx, 20);
2504     } else {
2505         return $re;
2506     }
2507 }
2508
2509 sub pp_match { matchop(@_, "m", "/") }
2510 sub pp_pushre { matchop(@_, "m", "/") }
2511 sub pp_qr { matchop(@_, "qr", "") }
2512
2513 sub pp_split {
2514     my $self = shift;
2515     my($op, $cx) = @_;
2516     my($kid, @exprs, $ary, $expr);
2517     $kid = $op->first;
2518     if ($ {$kid->pmreplroot}) {
2519         $ary = '@' . $self->gv_name($kid->pmreplroot);
2520     }
2521     for (; !null($kid); $kid = $kid->sibling) {
2522         push @exprs, $self->deparse($kid, 6);
2523     }
2524     $expr = "split(" . join(", ", @exprs) . ")";
2525     if ($ary) {
2526         return $self->maybe_parens("$ary = $expr", $cx, 7);
2527     } else {
2528         return $expr;
2529     }
2530 }
2531
2532 # oxime -- any of various compounds obtained chiefly by the action of
2533 # hydroxylamine on aldehydes and ketones and characterized by the
2534 # bivalent grouping C=NOH [Webster's Tenth]
2535
2536 my %substwords;
2537 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2538     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2539     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2540     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2541
2542 sub pp_subst {
2543     my $self = shift;
2544     my($op, $cx) = @_;
2545     my $kid = $op->first;
2546     my($binop, $var, $re, $repl) = ("", "", "", "");
2547     if ($op->flags & OPf_STACKED) {
2548         $binop = 1;
2549         $var = $self->deparse($kid, 20);
2550         $kid = $kid->sibling;
2551     }
2552     my $flags = "";
2553     if (null($op->pmreplroot)) {
2554         $repl = $self->dq($kid);
2555         $kid = $kid->sibling;
2556     } else {
2557         $repl = $op->pmreplroot->first; # skip substcont
2558         while ($repl->ppaddr eq "pp_entereval") {
2559             $repl = $repl->first;
2560             $flags .= "e";
2561         }
2562         if ($op->pmflags & PMf_EVAL) {
2563             $repl = $self->deparse($repl, 0);
2564         } else {
2565             $repl = $self->dq($repl);
2566         }
2567     }
2568     if (null $kid) {
2569         $re = re_uninterp(escape_str($op->precomp));
2570     } else {
2571         $re = $self->deparse($kid, 1);
2572     }
2573     $flags .= "e" if $op->pmflags & PMf_EVAL;
2574     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2575     $flags .= "i" if $op->pmflags & PMf_FOLD;
2576     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2577     $flags .= "o" if $op->pmflags & PMf_KEEP;
2578     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2579     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2580     $flags = $substwords{$flags} if $substwords{$flags};
2581     if ($binop) {
2582         return $self->maybe_parens("$var =~ s"
2583                                    . double_delim($re, $repl) . $flags,
2584                                    $cx, 20);
2585     } else {
2586         return "s". double_delim($re, $repl) . $flags;
2587     }
2588 }
2589
2590 1;
2591 __END__
2592
2593 =head1 NAME
2594
2595 B::Deparse - Perl compiler backend to produce perl code
2596
2597 =head1 SYNOPSIS
2598
2599 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-l>][B<,-s>I<LETTERS>] I<prog.pl>
2600
2601 =head1 DESCRIPTION
2602
2603 B::Deparse is a backend module for the Perl compiler that generates
2604 perl source code, based on the internal compiled structure that perl
2605 itself creates after parsing a program. The output of B::Deparse won't
2606 be exactly the same as the original source, since perl doesn't keep
2607 track of comments or whitespace, and there isn't a one-to-one
2608 correspondence between perl's syntactical constructions and their
2609 compiled form, but it will often be close. When you use the B<-p>
2610 option, the output also includes parentheses even when they are not
2611 required by precedence, which can make it easy to see if perl is
2612 parsing your expressions the way you intended.
2613
2614 Please note that this module is mainly new and untested code and is
2615 still under development, so it may change in the future.
2616
2617 =head1 OPTIONS
2618
2619 As with all compiler backend options, these must follow directly after
2620 the '-MO=Deparse', separated by a comma but not any white space.
2621
2622 =over 4
2623
2624 =item B<-l>
2625
2626 Add '#line' declarations to the output based on the line and file
2627 locations of the original code.
2628
2629 =item B<-p>
2630
2631 Print extra parentheses. Without this option, B::Deparse includes
2632 parentheses in its output only when they are needed, based on the
2633 structure of your program. With B<-p>, it uses parentheses (almost)
2634 whenever they would be legal. This can be useful if you are used to
2635 LISP, or if you want to see how perl parses your input. If you say
2636
2637     if ($var & 0x7f == 65) {print "Gimme an A!"}
2638     print ($which ? $a : $b), "\n";
2639     $name = $ENV{USER} or "Bob";
2640
2641 C<B::Deparse,-p> will print
2642
2643     if (($var & 0)) {
2644         print('Gimme an A!')
2645     };
2646     (print(($which ? $a : $b)), '???');
2647     (($name = $ENV{'USER'}) or '???')
2648
2649 which probably isn't what you intended (the C<'???'> is a sign that
2650 perl optimized away a constant value).
2651
2652 =item B<-q>
2653
2654 Expand double-quoted strings into the corresponding combinations of
2655 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
2656 instance, print
2657
2658     print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
2659
2660 as
2661
2662     print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
2663           . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
2664
2665 Note that the expanded form represents the way perl handles such
2666 constructions internally -- this option actually turns off the reverse
2667 translation that B::Deparse usually does. On the other hand, note that
2668 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
2669 of $y into a string before doing the assignment.
2670
2671 =item B<-u>I<PACKAGE>
2672
2673 Normally, B::Deparse deparses the main code of a program, all the subs
2674 called by the main program (and all the subs called by them,
2675 recursively), and any other subs in the main:: package. To include
2676 subs in other packages that aren't called directly, such as AUTOLOAD,
2677 DESTROY, other subs called automatically by perl, and methods, which
2678 aren't resolved to subs until runtime, use the B<-u> option. The
2679 argument to B<-u> is the name of a package, and should follow directly
2680 after the 'u'. Multiple B<-u> options may be given, separated by
2681 commas.  Note that unlike some other backends, B::Deparse doesn't
2682 (yet) try to guess automatically when B<-u> is needed -- you must
2683 invoke it yourself.
2684
2685 =item B<-s>I<LETTERS>
2686
2687 Tweak the style of B::Deparse's output. At the moment, only one style
2688 option is implemented:
2689
2690 =over 4
2691
2692 =item B<C>
2693
2694 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2695
2696     if (...) {
2697          ...
2698     } else {
2699          ...
2700     }
2701
2702 instead of
2703
2704     if (...) {
2705          ...
2706     }
2707     else {
2708          ...
2709     }
2710
2711 The default is not to cuddle.
2712
2713 =back
2714
2715 =back
2716
2717 =head1 BUGS
2718
2719 See the 'to do' list at the beginning of the module file.
2720
2721 =head1 AUTHOR
2722
2723 Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier
2724 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>.
2725
2726 =cut