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