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         $ary = $self->deparse($ary, 1);
1517         if (null $var) {
1518             if ($enter->flags & OPf_SPECIAL) { # thread special var
1519                 $var = $self->pp_threadsv($enter, 1);
1520             } else { # regular my() variable
1521                 $var = $self->pp_padsv($enter, 1);
1522                 if ($self->padname_sv($enter->targ)->IVX ==
1523                     $kid->first->first->sibling->last->cop_seq)
1524                 {
1525                     # If the scope of this variable closes at the last
1526                     # statement of the loop, it must have been
1527                     # declared here.
1528                     $var = "my " . $var;
1529                 }
1530             }
1531         } elsif ($var->ppaddr eq "pp_rv2gv") {
1532             $var = $self->pp_rv2sv($var, 1);
1533         } elsif ($var->ppaddr eq "pp_gv") {
1534             $var = "\$" . $self->deparse($var, 1);
1535         }
1536         $head = "foreach $var ($ary) ";
1537         $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1538     } elsif ($kid->ppaddr eq "pp_null") { # while/until
1539         $kid = $kid->first;
1540         my $name = {"pp_and" => "while", "pp_or" => "until"}
1541                     ->{$kid->ppaddr};
1542         $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
1543         $kid = $kid->first->sibling;
1544     } elsif ($kid->ppaddr eq "pp_stub") { # bare and empty
1545         return "{;}"; # {} could be a hashref
1546     }
1547     # The third-to-last kid is the continue block if the pointer used
1548     # by `next BLOCK' points to its first OP, which happens to be the
1549     # the op_next of the head of the _previous_ statement.
1550     # Unless it's a bare loop, in which case it's last, since there's
1551     # no unstack or extra nextstate.
1552     my($cont, $precont);
1553     if ($bare) {
1554         $cont = $kid->first;
1555         while (!null($cont->sibling)) {
1556             $precont = $cont;
1557             $cont = $cont->sibling;
1558         }
1559     } else {
1560         $cont = $kid->first;
1561         while (!null($cont->sibling->sibling->sibling)) {
1562             $precont = $cont;
1563             $cont = $cont->sibling;
1564         }
1565     }
1566 #    cluck $self->{'curcv'}->GV->NAME unless $precont;
1567     if ($precont and $ {$precont->next} == $ {$enter->nextop}) {
1568         my $state = $kid->first;
1569         my $cuddle = $self->{'cuddle'};
1570         my($expr, @exprs);
1571         for (; $$state != $$cont; $state = $state->sibling) {
1572             $expr = "";
1573             if (is_state $state) {
1574                 $expr = $self->deparse($state, 0);
1575                 $state = $state->sibling;
1576                 last if null $kid;
1577             }
1578             $expr .= $self->deparse($state, 0);
1579             push @exprs, $expr if $expr;
1580         }
1581         $kid = join(";\n", @exprs);
1582         $cont = $cuddle . "continue {\n\t" .
1583           $self->deparse($cont, 0) . "\n\b}\cK";
1584     } else {
1585         $cont = "\cK";
1586         $kid = $self->deparse($kid, 0);
1587     }
1588     return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1589 }
1590
1591 sub pp_leavetry {
1592     my $self = shift;
1593     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
1594 }
1595
1596 sub OP_CONST () { 5 }
1597 sub OP_STRINGIFY () { 65 }
1598
1599 sub pp_null {
1600     my $self = shift;
1601     my($op, $cx) = @_;
1602     if (class($op) eq "OP") {
1603         return "'???'" if $op->targ == OP_CONST; # old value is lost
1604     } elsif ($op->first->ppaddr eq "pp_pushmark") {
1605         return $self->pp_list($op, $cx);
1606     } elsif ($op->first->ppaddr eq "pp_enter") {
1607         return $self->pp_leave($op, $cx);
1608     } elsif ($op->targ == OP_STRINGIFY) {
1609         return $self->dquote($op);
1610     } elsif (!null($op->first->sibling) and
1611              $op->first->sibling->ppaddr eq "pp_readline" and
1612              $op->first->sibling->flags & OPf_STACKED) {
1613         return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1614                                    . $self->deparse($op->first->sibling, 7),
1615                                    $cx, 7);
1616     } elsif (!null($op->first->sibling) and
1617              $op->first->sibling->ppaddr eq "pp_trans" and
1618              $op->first->sibling->flags & OPf_STACKED) {
1619         return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1620                                    . $self->deparse($op->first->sibling, 20),
1621                                    $cx, 20);
1622     } else {
1623         return $self->deparse($op->first, $cx);
1624     }
1625 }
1626
1627 sub padname {
1628     my $self = shift;
1629     my $targ = shift;
1630     my $str = $self->padname_sv($targ)->PV;
1631     return padname_fix($str);
1632 }
1633
1634 sub padany {
1635     my $self = shift;
1636     my $op = shift;
1637     return substr($self->padname($op->targ), 1); # skip $/@/%
1638 }
1639
1640 sub pp_padsv {
1641     my $self = shift;
1642     my($op, $cx) = @_;
1643     return $self->maybe_my($op, $cx, $self->padname($op->targ));
1644 }
1645
1646 sub pp_padav { pp_padsv(@_) }
1647 sub pp_padhv { pp_padsv(@_) }
1648
1649 my @threadsv_names;
1650
1651 BEGIN {
1652     @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1653                        "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1654                        "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1655                        "!", "@");
1656 }
1657
1658 sub pp_threadsv {
1659     my $self = shift;
1660     my($op, $cx) = @_;
1661     return $self->maybe_local($op, $cx, "\$" .  $threadsv_names[$op->targ]);
1662 }
1663
1664 sub pp_gvsv {
1665     my $self = shift;
1666     my($op, $cx) = @_;
1667     return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
1668 }
1669
1670 sub pp_gv {
1671     my $self = shift;
1672     my($op, $cx) = @_;
1673     return $self->gv_name($op->gv);
1674 }
1675
1676 sub pp_aelemfast {
1677     my $self = shift;
1678     my($op, $cx) = @_;
1679     my $gv = $op->gv;
1680     return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1681 }
1682
1683 sub rv2x {
1684     my $self = shift;
1685     my($op, $cx, $type) = @_;
1686     my $kid = $op->first;
1687     my $scope = is_scope($kid);
1688     $kid = $self->deparse($kid, 0);
1689     return $type . ($scope ? "{$kid}" : $kid);
1690 }
1691
1692 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1693 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1694 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1695
1696 # skip rv2av
1697 sub pp_av2arylen {
1698     my $self = shift;
1699     my($op, $cx) = @_;
1700     if ($op->first->ppaddr eq "pp_padav") {
1701         return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
1702     } else {
1703         return $self->maybe_local($op, $cx, $self->rv2x($op->first, '$#'));
1704     }
1705 }
1706
1707 # skip down to the old, ex-rv2cv
1708 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
1709
1710 sub pp_rv2av {
1711     my $self = shift;
1712     my($op, $cx) = @_;
1713     my $kid = $op->first;
1714     if ($kid->ppaddr eq "pp_const") { # constant list
1715         my $av = $kid->sv;
1716         return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1717     } else {
1718         return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
1719     }
1720  }
1721
1722
1723 sub elem {
1724     my $self = shift;
1725     my ($op, $cx, $left, $right, $padname) = @_;
1726     my($array, $idx) = ($op->first, $op->first->sibling);
1727     unless ($array->ppaddr eq $padname) { # Maybe this has been fixed
1728         $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1729     }
1730     if ($array->ppaddr eq $padname) {
1731         $array = $self->padany($array);
1732     } elsif (is_scope($array)) { # ${expr}[0]
1733         $array = "{" . $self->deparse($array, 0) . "}";
1734     } elsif (is_scalar $array) { # $x[0], $$x[0], ...
1735         $array = $self->deparse($array, 24);
1736     } else {
1737         # $x[20][3]{hi} or expr->[20]
1738         my $arrow;
1739         $arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/;
1740         return $self->deparse($array, 24) . $arrow .
1741             $left . $self->deparse($idx, 1) . $right;
1742     }
1743     $idx = $self->deparse($idx, 1);
1744     return "\$" . $array . $left . $idx . $right;
1745 }
1746
1747 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) }
1748 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) }
1749
1750 sub pp_gelem {
1751     my $self = shift;
1752     my($op, $cx) = @_;
1753     my($glob, $part) = ($op->first, $op->last);
1754     $glob = $glob->first; # skip rv2gv
1755     $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug
1756     my $scope = is_scope($glob);
1757     $glob = $self->deparse($glob, 0);
1758     $part = $self->deparse($part, 1);
1759     return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
1760 }
1761
1762 sub slice {
1763     my $self = shift;
1764     my ($op, $cx, $left, $right, $regname, $padname) = @_;
1765     my $last;
1766     my(@elems, $kid, $array, $list);
1767     if (class($op) eq "LISTOP") {
1768         $last = $op->last;
1769     } else { # ex-hslice inside delete()
1770         for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
1771         $last = $kid;
1772     }
1773     $array = $last;
1774     $array = $array->first
1775         if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null";
1776     if (is_scope($array)) {
1777         $array = "{" . $self->deparse($array, 0) . "}";
1778     } elsif ($array->ppaddr eq $padname) {
1779         $array = $self->padany($array);
1780     } else {
1781         $array = $self->deparse($array, 24);
1782     }
1783     $kid = $op->first->sibling; # skip pushmark
1784     if ($kid->ppaddr eq "pp_list") {
1785         $kid = $kid->first->sibling; # skip list, pushmark
1786         for (; !null $kid; $kid = $kid->sibling) {
1787             push @elems, $self->deparse($kid, 6);
1788         }
1789         $list = join(", ", @elems);
1790     } else {
1791         $list = $self->deparse($kid, 1);
1792     }
1793     return "\@" . $array . $left . $list . $right;
1794 }
1795
1796 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]",
1797                                       "pp_rv2av", "pp_padav")) }
1798 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}",
1799                                       "pp_rv2hv", "pp_padhv")) }
1800
1801 sub pp_lslice {
1802     my $self = shift;
1803     my($op, $cx) = @_;
1804     my $idx = $op->first;
1805     my $list = $op->last;
1806     my(@elems, $kid);
1807     $list = $self->deparse($list, 1);
1808     $idx = $self->deparse($idx, 1);
1809     return "($list)" . "[$idx]";
1810 }
1811
1812 sub OPpENTERSUB_AMPER () { 8 }
1813
1814 sub OPf_WANT () { 3 }
1815 sub OPf_WANT_VOID () { 1 }
1816 sub OPf_WANT_SCALAR () { 2 }
1817 sub OPf_WANT_LIST () { 2 }
1818
1819 sub want_scalar {
1820     my $op = shift;
1821     return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
1822 }
1823
1824 sub pp_entersub {
1825     my $self = shift;
1826     my($op, $cx) = @_;
1827     my $prefix = "";
1828     my $amper = "";
1829     my $proto = undef;
1830     my $simple = 0;
1831     my($kid, $args, @exprs);
1832     if (not null $op->first->sibling) { # method
1833         $kid = $op->first->sibling; # skip pushmark
1834         my $obj = $self->deparse($kid, 24);
1835         $kid = $kid->sibling;
1836         for (; not null $kid->sibling; $kid = $kid->sibling) {
1837             push @exprs, $self->deparse($kid, 6);
1838         }
1839         my $meth = $kid->first;
1840         if ($meth->ppaddr eq "pp_const") {
1841             $meth = $meth->sv->PV; # needs to be bare
1842         } else {
1843             $meth = $self->deparse($meth, 1);
1844         }
1845         $args = join(", ", @exprs);
1846         $kid = $obj . "->" . $meth;
1847         if ($args) {
1848             return $kid . "(" . $args . ")"; # parens mandatory
1849         } else {
1850             return $kid; # toke.c fakes parens
1851         }
1852     }
1853     # else, not a method
1854     if ($op->flags & OPf_SPECIAL) {
1855         $prefix = "do ";
1856     } elsif ($op->private & OPpENTERSUB_AMPER) {
1857         $amper = "&";
1858     }
1859     $kid = $op->first;
1860     $kid = $kid->first->sibling; # skip ex-list, pushmark
1861     for (; not null $kid->sibling; $kid = $kid->sibling) {
1862         push @exprs, $kid;
1863     }
1864     if (is_scope($kid)) {
1865         $amper = "&";
1866         $kid = "{" . $self->deparse($kid, 0) . "}";
1867     } elsif ($kid->first->ppaddr eq "pp_gv") {
1868         my $gv = $kid->first->gv;
1869         if (class($gv->CV) ne "SPECIAL") {
1870             $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
1871         }
1872         $simple = 1;
1873         $kid = $self->deparse($kid, 24);
1874     } elsif (is_scalar $kid->first) {
1875         $amper = "&";
1876         $kid = $self->deparse($kid, 24);
1877     } else {
1878         $prefix = "";
1879         $kid = $self->deparse($kid, 24) . "->";
1880     }
1881     if (defined $proto and not $amper) {
1882         my($arg, $real);
1883         my $doneok = 0;
1884         my @args = @exprs;
1885         my @reals;
1886         $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
1887         while ($proto) {
1888             $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
1889             my $chr = $1;
1890             if ($chr eq "") {
1891                 undef $proto if @args;
1892             } elsif ($chr eq ";") {
1893                 $doneok = 1;
1894             } elsif ($chr eq "@" or $chr eq "%") {
1895                 push @reals, map($self->deparse($_, 6), @args);
1896                 @args = ();
1897             } else {
1898                 $arg = shift @args;
1899                 undef $proto, last unless $arg;
1900                 if ($chr eq "\$") {
1901                     if (want_scalar $arg) {
1902                         push @reals, $self->deparse($arg, 6);
1903                     } else {
1904                         undef $proto;
1905                     }
1906                 } elsif ($chr eq "&") {
1907                     if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) {
1908                         push @reals, $self->deparse($arg, 6);
1909                     } else {
1910                         undef $proto;
1911                     }
1912                 } elsif ($chr eq "*") {
1913                     if ($arg->ppaddr =~ /^pp_s?refgen$/
1914                         and $arg->first->first->ppaddr eq "pp_rv2gv")
1915                     {
1916                         $real = $arg->first->first; # skip refgen, null
1917                         if ($real->first->ppaddr eq "pp_gv") {
1918                             push @reals, $self->deparse($real, 6);
1919                         } else {
1920                             push @reals, $self->deparse($real->first, 6);
1921                         }
1922                     } else {
1923                         undef $proto;
1924                     }
1925                 } elsif (substr($chr, 0, 1) eq "\\") {
1926                     $chr = substr($chr, 1);
1927                     if ($arg->ppaddr =~ /^pp_s?refgen$/ and
1928                         !null($real = $arg->first) and
1929                         ($chr eq "\$" && is_scalar($real->first)
1930                          or ($chr eq "\@"
1931                              && $real->first->sibling->ppaddr
1932                              =~ /^pp_(rv2|pad)av$/)
1933                          or ($chr eq "%"
1934                              && $real->first->sibling->ppaddr
1935                              =~ /^pp_(rv2|pad)hv$/)
1936                          #or ($chr eq "&" # This doesn't work
1937                          #   && $real->first->ppaddr eq "pp_rv2cv")
1938                          or ($chr eq "*"
1939                              && $real->first->ppaddr eq "pp_rv2gv")))
1940                     {
1941                         push @reals, $self->deparse($real, 6);
1942                     } else {
1943                         undef $proto;
1944                     }
1945                 }
1946             }
1947         }
1948         undef $proto if $proto and !$doneok;
1949         undef $proto if @args;
1950         $args = join(", ", @reals);
1951         $amper = "";
1952         unless (defined $proto) {
1953             $amper = "&";
1954             $args = join(", ", map($self->deparse($_, 6), @exprs));
1955         }
1956     } else {
1957         $args = join(", ", map($self->deparse($_, 6), @exprs));
1958     }
1959     if ($prefix or $amper) {
1960         if ($op->flags & OPf_STACKED) {
1961             return $prefix . $amper . $kid . "(" . $args . ")";
1962         } else {
1963             return $prefix . $amper. $kid;
1964         }
1965     } else {
1966         if (defined $proto and $proto eq "") {
1967             return $kid;
1968         } elsif ($proto eq "\$") {
1969             return $self->maybe_parens_func($kid, $args, $cx, 16);
1970         } elsif ($proto or $simple) {
1971             return $self->maybe_parens_func($kid, $args, $cx, 5);
1972         } else {
1973             return "$kid(" . $args . ")";
1974         }
1975     }
1976 }
1977
1978 sub pp_enterwrite { unop(@_, "write") }
1979
1980 # escape things that cause interpolation in double quotes,
1981 # but not character escapes
1982 sub uninterp {
1983     my($str) = @_;
1984     $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
1985     return $str;
1986 }
1987
1988 # the same, but treat $|, $), and $ at the end of the string differently
1989 sub re_uninterp {
1990     my($str) = @_;
1991     $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
1992     $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
1993     return $str;
1994 }
1995
1996 # character escapes, but not delimiters that might need to be escaped
1997 sub escape_str { # ASCII
1998     my($str) = @_;
1999     $str =~ s/\a/\\a/g;
2000 #    $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2001     $str =~ s/\t/\\t/g;
2002     $str =~ s/\n/\\n/g;
2003     $str =~ s/\e/\\e/g;
2004     $str =~ s/\f/\\f/g;
2005     $str =~ s/\r/\\r/g;
2006     $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2007     $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2008     return $str;
2009 }
2010
2011 # Don't do this for regexen
2012 sub unback {
2013     my($str) = @_;
2014     $str =~ s/\\/\\\\/g;
2015     return $str;
2016 }
2017
2018 sub balanced_delim {
2019     my($str) = @_;
2020     my @str = split //, $str;
2021     my($ar, $open, $close, $fail, $c, $cnt);
2022     for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2023         ($open, $close) = @$ar;
2024         $fail = 0; $cnt = 0;
2025         for $c (@str) {
2026             if ($c eq $open) {
2027                 $cnt++;
2028             } elsif ($c eq $close) {
2029                 $cnt--;
2030                 if ($cnt < 0) {
2031                     $fail = 1;
2032                     last;
2033                 }
2034             }
2035         }
2036         $fail = 1 if $cnt != 0;
2037         return ($open, "$open$str$close") if not $fail;
2038     }
2039     return ("", $str);
2040 }
2041
2042 sub single_delim {
2043     my($q, $default, $str) = @_;
2044     return "$default$str$default" if index($str, $default) == -1;
2045     my($succeed, $delim);
2046     ($succeed, $str) = balanced_delim($str);
2047     return "$q$str" if $succeed;
2048     for $delim ('/', '"', '#') {
2049         return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2050     }
2051     $str =~ s/$default/\\$default/g;
2052     return "$default$str$default";
2053 }
2054
2055 sub SVf_IOK () {0x10000}
2056 sub SVf_NOK () {0x20000}
2057 sub SVf_ROK () {0x80000}
2058
2059 sub const {
2060     my $sv = shift;
2061     if (class($sv) eq "SPECIAL") {
2062         return ('undef', '1', '0')[$$sv-1];
2063     } elsif ($sv->FLAGS & SVf_IOK) {
2064         return $sv->IV;
2065     } elsif ($sv->FLAGS & SVf_NOK) {
2066         return $sv->NV;
2067     } elsif ($sv->FLAGS & SVf_ROK) {
2068         return "\\(" . const($sv->RV) . ")"; # constant folded
2069     } else {
2070         my $str = $sv->PV;
2071         if ($str =~ /[^ -~]/) { # ASCII
2072             return single_delim("qq", '"', uninterp escape_str unback $str);
2073         } else {
2074             $str =~ s/\\/\\\\/g;
2075             return single_delim("q", "'", $str);
2076         }
2077     }
2078 }
2079
2080 sub pp_const {
2081     my $self = shift;
2082     my($op, $cx) = @_;
2083 #    if ($op->private & OPp_CONST_BARE) { # trouble with `=>' autoquoting
2084 #       return $op->sv->PV;
2085 #    }
2086     return const($op->sv);
2087 }
2088
2089 sub dq {
2090     my $self = shift;
2091     my $op = shift;
2092     my $type = $op->ppaddr;
2093     if ($type eq "pp_const") {
2094         return uninterp(escape_str(unback($op->sv->PV)));
2095     } elsif ($type eq "pp_concat") {
2096         return $self->dq($op->first) . $self->dq($op->last);
2097     } elsif ($type eq "pp_uc") {
2098         return '\U' . $self->dq($op->first->sibling) . '\E';
2099     } elsif ($type eq "pp_lc") {
2100         return '\L' . $self->dq($op->first->sibling) . '\E';
2101     } elsif ($type eq "pp_ucfirst") {
2102         return '\u' . $self->dq($op->first->sibling);
2103     } elsif ($type eq "pp_lcfirst") {
2104         return '\l' . $self->dq($op->first->sibling);
2105     } elsif ($type eq "pp_quotemeta") {
2106         return '\Q' . $self->dq($op->first->sibling) . '\E';
2107     } elsif ($type eq "pp_join") {
2108         return $self->deparse($op->last, 26); # was join($", @ary)
2109     } else {
2110         return $self->deparse($op, 26);
2111     }
2112 }
2113
2114 sub pp_backtick {
2115     my $self = shift;
2116     my($op, $cx) = @_;
2117     # skip pushmark
2118     return single_delim("qx", '`', $self->dq($op->first->sibling));
2119 }
2120
2121 sub dquote {
2122     my $self = shift;
2123     my $op = shift;
2124     # skip ex-stringify, pushmark
2125     return single_delim("qq", '"', $self->dq($op->first->sibling));
2126 }
2127
2128 # OP_STRINGIFY is a listop, but it only ever has one arg (?)
2129 sub pp_stringify { dquote(@_) }
2130
2131 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2132 # note that tr(from)/to/ is OK, but not tr/from/(to)
2133 sub double_delim {
2134     my($from, $to) = @_;
2135     my($succeed, $delim);
2136     if ($from !~ m[/] and $to !~ m[/]) {
2137         return "/$from/$to/";
2138     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2139         if (($succeed, $to) = balanced_delim($to) and $succeed) {
2140             return "$from$to";
2141         } else {
2142             for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2143                 return "$from$delim$to$delim" if index($to, $delim) == -1;
2144             }
2145             $to =~ s[/][\\/]g;
2146             return "$from/$to/";
2147         }
2148     } else {
2149         for $delim ('/', '"', '#') { # note no '
2150             return "$delim$from$delim$to$delim"
2151                 if index($to . $from, $delim) == -1;
2152         }
2153         $from =~ s[/][\\/]g;
2154         $to =~ s[/][\\/]g;
2155         return "/$from/$to/";
2156     }
2157 }
2158
2159 sub pchr { # ASCII
2160     my($n) = @_;
2161     if ($n == ord '\\') {
2162         return '\\\\';
2163     } elsif ($n >= ord(' ') and $n <= ord('~')) {
2164         return chr($n);
2165     } elsif ($n == ord "\a") {
2166         return '\\a';
2167     } elsif ($n == ord "\b") {
2168         return '\\b';
2169     } elsif ($n == ord "\t") {
2170         return '\\t';
2171     } elsif ($n == ord "\n") {
2172         return '\\n';
2173     } elsif ($n == ord "\e") {
2174         return '\\e';
2175     } elsif ($n == ord "\f") {
2176         return '\\f';
2177     } elsif ($n == ord "\r") {
2178         return '\\r';
2179     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2180         return '\\c' . chr(ord("@") + $n);
2181     } else {
2182 #       return '\x' . sprintf("%02x", $n);
2183         return '\\' . sprintf("%03o", $n);
2184     }
2185 }
2186
2187 sub collapse {
2188     my(@chars) = @_;
2189     my($c, $str, $tr);
2190     for ($c = 0; $c < @chars; $c++) {
2191         $tr = $chars[$c];
2192         $str .= pchr($tr);
2193         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2194             $chars[$c + 2] == $tr + 2)
2195         {
2196             for (; $c <= $#chars and $chars[$c + 1] == $chars[$c] + 1; $c++) {}
2197             $str .= "-";
2198             $str .= pchr($chars[$c]);
2199         }
2200     }
2201     return $str;
2202 }
2203
2204 sub OPpTRANS_SQUASH () { 16 }
2205 sub OPpTRANS_DELETE () { 32 }
2206 sub OPpTRANS_COMPLEMENT () { 64 }
2207
2208 sub pp_trans {
2209     my $self = shift;
2210     my($op, $cx) = @_;
2211     my(@table) = unpack("s256", $op->pv);
2212     my($c, $tr, @from, @to, @delfrom, $delhyphen);
2213     if ($table[ord "-"] != -1 and
2214         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2215     {
2216         $tr = $table[ord "-"];
2217         $table[ord "-"] = -1;
2218         if ($tr >= 0) {
2219             @from = ord("-");
2220             @to = $tr;
2221         } else { # -2 ==> delete
2222             $delhyphen = 1;
2223         }
2224     }
2225     for ($c = 0; $c < 256; $c++) {
2226         $tr = $table[$c];
2227         if ($tr >= 0) {
2228             push @from, $c; push @to, $tr;
2229         } elsif ($tr == -2) {
2230             push @delfrom, $c;
2231         }
2232     }
2233     my $flags;
2234     @from = (@from, @delfrom);
2235     if ($op->private & OPpTRANS_COMPLEMENT) {
2236         $flags .= "c";
2237         my @newfrom = ();
2238         my %from;
2239         @from{@from} = (1) x @from;
2240         for ($c = 0; $c < 256; $c++) {
2241             push @newfrom, $c unless $from{$c};
2242         }
2243         @from = @newfrom;
2244     }
2245     if ($op->private & OPpTRANS_DELETE) {
2246         $flags .= "d";
2247     } else {
2248         pop @to while $#to and $to[$#to] == $to[$#to -1];
2249     }
2250     $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2251     my($from, $to);
2252     $from = collapse(@from);
2253     $to = collapse(@to);
2254     $from .= "-" if $delhyphen;
2255     return "tr" . double_delim($from, $to) . $flags;
2256 }
2257
2258 # Like dq(), but different
2259 sub re_dq {
2260     my $self = shift;
2261     my $op = shift;
2262     my $type = $op->ppaddr;
2263     if ($type eq "pp_const") {
2264         return uninterp($op->sv->PV);
2265     } elsif ($type eq "pp_concat") {
2266         return $self->re_dq($op->first) . $self->re_dq($op->last);
2267     } elsif ($type eq "pp_uc") {
2268         return '\U' . $self->re_dq($op->first->sibling) . '\E';
2269     } elsif ($type eq "pp_lc") {
2270         return '\L' . $self->re_dq($op->first->sibling) . '\E';
2271     } elsif ($type eq "pp_ucfirst") {
2272         return '\u' . $self->re_dq($op->first->sibling);
2273     } elsif ($type eq "pp_lcfirst") {
2274         return '\l' . $self->re_dq($op->first->sibling);
2275     } elsif ($type eq "pp_quotemeta") {
2276         return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2277     } elsif ($type eq "pp_join") {
2278         return $self->deparse($op->last, 26); # was join($", @ary)
2279     } else {
2280         return $self->deparse($op, 26);
2281     }
2282 }
2283
2284 sub pp_regcomp {
2285     my $self = shift;
2286     my($op, $cx) = @_;
2287     my $kid = $op->first;
2288     $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe";
2289     return $self->re_dq($kid);
2290 }
2291
2292 sub OPp_RUNTIME () { 64 }
2293
2294 sub PMf_ONCE () { 0x2 }
2295 sub PMf_SKIPWHITE () { 0x10 }
2296 sub PMf_FOLD () { 0x20 }
2297 sub PMf_CONST () { 0x40 }
2298 sub PMf_KEEP () { 0x80 }
2299 sub PMf_GLOBAL () { 0x100 }
2300 sub PMf_CONTINUE () { 0x200 }
2301 sub PMf_EVAL () { 0x400 }
2302 sub PMf_MULTILINE () { 0x1000 }
2303 sub PMf_SINGLELINE () { 0x2000 }
2304 sub PMf_LOCALE () { 0x4000 }
2305 sub PMf_EXTENDED () { 0x8000 }
2306
2307 # osmic acid -- see osmium tetroxide
2308
2309 my %matchwords;
2310 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2311     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2312     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2313
2314 sub pp_match {
2315     my $self = shift;
2316     my($op, $cx) = @_;
2317     my $kid = $op->first;
2318     my ($binop, $var, $re) = ("", "", "");
2319     if ($op->flags & OPf_STACKED) {
2320         $binop = 1;
2321         $var = $self->deparse($kid, 20);
2322         $kid = $kid->sibling;
2323     }
2324     if (null $kid) {
2325         $re = re_uninterp(escape_str($op->precomp));
2326     } else {
2327         $re = $self->deparse($kid, 1);
2328     }
2329     my $flags = "";
2330     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2331     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2332     $flags .= "i" if $op->pmflags & PMf_FOLD;
2333     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2334     $flags .= "o" if $op->pmflags & PMf_KEEP;
2335     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2336     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2337     $flags = $matchwords{$flags} if $matchwords{$flags};
2338     if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2339         $re =~ s/\?/\\?/g;
2340         $re = "?$re?";
2341     } else {
2342         $re = single_delim("m", "/", $re);
2343     }
2344     $re = $re . $flags;
2345     if ($binop) {
2346         return $self->maybe_parens("$var =~ $re", $cx, 20);
2347     } else {
2348         return $re;
2349     }
2350 }
2351
2352 sub pp_pushre { pp_match(@_) }
2353
2354 sub pp_split {
2355     my $self = shift;
2356     my($op, $cx) = @_;
2357     my($kid, @exprs, $ary, $expr);
2358     $kid = $op->first;
2359     if ($ {$kid->pmreplroot}) {
2360         $ary = '@' . $self->gv_name($kid->pmreplroot);
2361     }
2362     for (; !null($kid); $kid = $kid->sibling) {
2363         push @exprs, $self->deparse($kid, 6);
2364     }
2365     $expr = "split(" . join(", ", @exprs) . ")";
2366     if ($ary) {
2367         return $self->maybe_parens("$ary = $expr", $cx, 7);
2368     } else {
2369         return $expr;
2370     }
2371 }
2372
2373 # oxime -- any of various compounds obtained chiefly by the action of
2374 # hydroxylamine on aldehydes and ketones and characterized by the
2375 # bivalent grouping C=NOH [Webster's Tenth]
2376
2377 my %substwords;
2378 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2379     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2380     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2381     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2382
2383 sub pp_subst {
2384     my $self = shift;
2385     my($op, $cx) = @_;
2386     my $kid = $op->first;
2387     my($binop, $var, $re, $repl) = ("", "", "", "");
2388     if ($op->flags & OPf_STACKED) {
2389         $binop = 1;
2390         $var = $self->deparse($kid, 20);
2391         $kid = $kid->sibling;
2392     }
2393     my $flags = "";
2394     if (null($op->pmreplroot)) {
2395         $repl = $self->dq($kid);
2396         $kid = $kid->sibling;
2397     } else {
2398         $repl = $op->pmreplroot->first; # skip substcont
2399         while ($repl->ppaddr eq "pp_entereval") {
2400             $repl = $repl->first;
2401             $flags .= "e";
2402         }
2403         $repl = $self->dq($repl);
2404     }
2405     if (null $kid) {
2406         $re = re_uninterp(escape_str($op->precomp));
2407     } else {
2408         $re = $self->deparse($kid, 1);
2409     }
2410     $flags .= "e" if $op->pmflags & PMf_EVAL;
2411     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2412     $flags .= "i" if $op->pmflags & PMf_FOLD;
2413     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2414     $flags .= "o" if $op->pmflags & PMf_KEEP;
2415     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2416     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2417     $flags = $substwords{$flags} if $substwords{$flags};
2418     if ($binop) {
2419         return $self->maybe_parens("$var =~ s"
2420                                    . double_delim($re, $repl) . $flags,
2421                                    $cx, 20);
2422     } else {
2423         return "s". double_delim($re, $repl) . $flags;
2424     }
2425 }
2426
2427 1;
2428 __END__
2429
2430 =head1 NAME
2431
2432 B::Deparse - Perl compiler backend to produce perl code
2433
2434 =head1 SYNOPSIS
2435
2436 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-s>I<LETTERS>] I<prog.pl>
2437
2438 =head1 DESCRIPTION
2439
2440 B::Deparse is a backend module for the Perl compiler that generates
2441 perl source code, based on the internal compiled structure that perl
2442 itself creates after parsing a program. The output of B::Deparse won't
2443 be exactly the same as the original source, since perl doesn't keep
2444 track of comments or whitespace, and there isn't a one-to-one
2445 correspondence between perl's syntactical constructions and their
2446 compiled form, but it will often be close. When you use the B<-p>
2447 option, the output also includes parentheses even when they are not
2448 required by precedence, which can make it easy to see if perl is
2449 parsing your expressions the way you intended.
2450
2451 Please note that this module is mainly new and untested code and is
2452 still under development, so it may change in the future.
2453
2454 =head1 OPTIONS
2455
2456 As with all compiler backend options, these must follow directly after
2457 the '-MO=Deparse', separated by a comma but not any white space.
2458
2459 =over 4
2460
2461 =item B<-p>
2462
2463 Print extra parentheses. Without this option, B::Deparse includes
2464 parentheses in its output only when they are needed, based on the
2465 structure of your program. With B<-p>, it uses parentheses (almost)
2466 whenever they would be legal. This can be useful if you are used to
2467 LISP, or if you want to see how perl parses your input. If you say
2468
2469     if ($var & 0x7f == 65) {print "Gimme an A!"}
2470     print ($which ? $a : $b), "\n";
2471     $name = $ENV{USER} or "Bob";
2472
2473 C<B::Deparse,-p> will print
2474
2475     if (($var & 0)) {
2476         print('Gimme an A!')
2477     };
2478     (print(($which ? $a : $b)), '???');
2479     (($name = $ENV{'USER'}) or '???')
2480
2481 which probably isn't what you intended (the C<'???'> is a sign that
2482 perl optimized away a constant value).
2483
2484 =item B<-u>I<PACKAGE>
2485
2486 Normally, B::Deparse deparses the main code of a program, all the subs
2487 called by the main program (and all the subs called by them,
2488 recursively), and any other subs in the main:: package. To include
2489 subs in other packages that aren't called directly, such as AUTOLOAD,
2490 DESTROY, other subs called automatically by perl, and methods, which
2491 aren't resolved to subs until runtime, use the B<-u> option. The
2492 argument to B<-u> is the name of a package, and should follow directly
2493 after the 'u'. Multiple B<-u> options may be given, separated by
2494 commas.  Note that unlike some other backends, B::Deparse doesn't
2495 (yet) try to guess automatically when B<-u> is needed -- you must
2496 invoke it yourself.
2497
2498 =item B<-s>I<LETTERS>
2499
2500 Tweak the style of B::Deparse's output. At the moment, only one style
2501 option is implemented:
2502
2503 =over 4
2504
2505 =item B<C>
2506
2507 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2508
2509     if (...) {
2510          ...
2511     } else {
2512          ...
2513     }
2514
2515 instead of
2516
2517     if (...) {
2518          ...
2519     }
2520     else {
2521          ...
2522     }
2523
2524 The default is not to cuddle.
2525
2526 =back
2527
2528 =back
2529
2530 =head1 BUGS
2531
2532 See the 'to do' list at the beginning of the module file.
2533
2534 =head1 AUTHOR
2535
2536 Stephen McCamant <alias@mcs.com>, based on an earlier version by
2537 Malcolm Beattie <mbeattie@sable.ox.ac.uk>.
2538
2539 =cut