ext/B/B/Deparse.pm

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