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