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