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