ext/B/B/Deparse.pm

   1 # B::Deparse.pm
   2 # Copyright (c) 1998, 1999, 2000 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', 'croak';
  11 use B qw(class main_root main_start main_cv svref_2object opnumber cstring
  12          OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
  13          OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
  14          OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
  15          OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
  16          OPpCONST_ARYBASE OPpEXISTS_SUB
  17          SVf_IOK SVf_NOK SVf_ROK SVf_POK
  18          CVf_METHOD CVf_LOCKED CVf_LVALUE
  19          PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
  20          PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
  21 $VERSION = 0.60;
  22 use strict;
  23 use warnings ();
  24
  25 # Changes between 0.50 and 0.51:
  26 # - fixed nulled leave with live enter in sort { }
  27 # - fixed reference constants (\"str")
  28 # - handle empty programs gracefully
  29 # - handle infinte loops (for (;;) {}, while (1) {})
  30 # - differentiate between `for my $x ...' and `my $x; for $x ...'
  31 # - various minor cleanups
  32 # - moved globals into an object
  33 # - added `-u', like B::C
  34 # - package declarations using cop_stash
  35 # - subs, formats and code sorted by cop_seq
  36 # Changes between 0.51 and 0.52:
  37 # - added pp_threadsv (special variables under USE_THREADS)
  38 # - added documentation
  39 # Changes between 0.52 and 0.53:
  40 # - many changes adding precedence contexts and associativity
  41 # - added `-p' and `-s' output style options
  42 # - various other minor fixes
  43 # Changes between 0.53 and 0.54:
  44 # - added support for new `for (1..100)' optimization,
  45 #   thanks to Gisle Aas
  46 # Changes between 0.54 and 0.55:
  47 # - added support for new qr// construct
  48 # - added support for new pp_regcreset OP
  49 # Changes between 0.55 and 0.56:
  50 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
  51 # - fixed $# on non-lexicals broken in last big rewrite
  52 # - added temporary fix for change in opcode of OP_STRINGIFY
  53 # - fixed problem in 0.54's for() patch in `for (@ary)'
  54 # - fixed precedence in conditional of ?:
  55 # - tweaked list paren elimination in `my($x) = @_'
  56 # - made continue-block detection trickier wrt. null ops
  57 # - fixed various prototype problems in pp_entersub
  58 # - added support for sub prototypes that never get GVs
  59 # - added unquoting for special filehandle first arg in truncate
  60 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
  61 # - added semicolons at the ends of blocks
  62 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
  63 # Changes between 0.56 and 0.561:
  64 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
  65 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
  66 # Changes between 0.561 and 0.57:
  67 # - stylistic changes to symbolic constant stuff
  68 # - handled scope in s///e replacement code
  69 # - added unquote option for expanding "" into concats, etc.
  70 # - split method and proto parts of pp_entersub into separate functions
  71 # - various minor cleanups
  72 # Changes after 0.57:
  73 # - added parens in \&foo (patch by Albert Dvornik)
  74 # Changes between 0.57 and 0.58:
  75 # - fixed `0' statements that weren't being printed
  76 # - added methods for use from other programs
  77 #   (based on patches from James Duncan and Hugo van der Sanden)
  78 # - added -si and -sT to control indenting (also based on a patch from Hugo)
  79 # - added -sv to print something else instead of '???'
  80 # - preliminary version of utf8 tr/// handling
  81 # Changes after 0.58:
  82 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
  83 # - added support for Hugo's new OP_SETSTATE (like nextstate)
  84 # Changes between 0.58 and 0.59
  85 # - added support for Chip's OP_METHOD_NAMED
  86 # - added support for Ilya's OPpTARGET_MY optimization
  87 # - elided arrows before `()' subscripts when possible
  88 # Changes between 0.59 and 0.60
  89 # - support for method attribues was added
  90 # - some warnings fixed
  91 # - separate recognition of constant subs
  92 # - rewrote continue block handling, now recoginizing for loops
  93 # - added more control of expanding control structures
  94
  95 # Todo:
  96 # - finish tr/// changes
  97 # - add option for even more parens (generalize \&foo change)
  98 # - left/right context
  99 # - treat top-level block specially for incremental output
 100 # - copy comments (look at real text with $^P?)
 101 # - avoid semis in one-statement blocks
 102 # - associativity of &&=, ||=, ?:
 103 # - ',' => '=>' (auto-unquote?)
 104 # - break long lines ("\r" as discretionary break?)
 105 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
 106 # - more style options: brace style, hex vs. octal, quotes, ...
 107 # - print big ints as hex/octal instead of decimal (heuristic?)
 108 # - handle `my $x if 0'?
 109 # - coordinate with Data::Dumper (both directions? see previous)
 110 # - version using op_next instead of op_first/sibling?
 111 # - avoid string copies (pass arrays, one big join?)
 112 # - here-docs?
 113 # - <DATA>?
 114
 115 # Tests that will always fail:
 116 # comp/redef.t -- all (redefinition happens at compile time)
 117
 118 # Object fields (were globals):
 119 #
 120 # avoid_local:
 121 # (local($a), local($b)) and local($a, $b) have the same internal
 122 # representation but the short form looks better. We notice we can
 123 # use a large-scale local when checking the list, but need to prevent
 124 # individual locals too. This hash holds the addresses of OPs that
 125 # have already had their local-ness accounted for. The same thing
 126 # is done with my().
 127 #
 128 # curcv:
 129 # CV for current sub (or main program) being deparsed
 130 #
 131 # curcop:
 132 # COP for statement being deparsed
 133 #
 134 # curstash:
 135 # name of the current package for deparsed code
 136 #
 137 # subs_todo:
 138 # array of [cop_seq, CV, is_format?] for subs and formats we still
 139 # want to deparse
 140 #
 141 # protos_todo:
 142 # as above, but [name, prototype] for subs that never got a GV
 143 #
 144 # subs_done, forms_done:
 145 # keys are addresses of GVs for subs and formats we've already
 146 # deparsed (or at least put into subs_todo)
 147 #
 148 # subs_declared
 149 # keys are names of subs for which we've printed declarations.
 150 # That means we can omit parentheses from the arguments.
 151 #
 152 # parens: -p
 153 # linenums: -l
 154 # unquote: -q
 155 # cuddle: ` ' or `\n', depending on -sC
 156 # indent_size: -si
 157 # use_tabs: -sT
 158 # ex_const: -sv
 159
 160 # A little explanation of how precedence contexts and associativity
 161 # work:
 162 #
 163 # deparse() calls each per-op subroutine with an argument $cx (short
 164 # for context, but not the same as the cx* in the perl core), which is
 165 # a number describing the op's parents in terms of precedence, whether
 166 # they're inside an expression or at statement level, etc.  (see
 167 # chart below). When ops with children call deparse on them, they pass
 168 # along their precedence. Fractional values are used to implement
 169 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
 170 # parentheses hacks. The major disadvantage of this scheme is that
 171 # it doesn't know about right sides and left sides, so say if you
 172 # assign a listop to a variable, it can't tell it's allowed to leave
 173 # the parens off the listop.
 174
 175 # Precedences:
 176 # 26             [TODO] inside interpolation context ("")
 177 # 25 left        terms and list operators (leftward)
 178 # 24 left        ->
 179 # 23 nonassoc    ++ --
 180 # 22 right       **
 181 # 21 right       ! ~ \ and unary + and -
 182 # 20 left        =~ !~
 183 # 19 left        * / % x
 184 # 18 left        + - .
 185 # 17 left        << >>
 186 # 16 nonassoc    named unary operators
 187 # 15 nonassoc    < > <= >= lt gt le ge
 188 # 14 nonassoc    == != <=> eq ne cmp
 189 # 13 left        &
 190 # 12 left        | ^
 191 # 11 left        &&
 192 # 10 left        ||
 193 #  9 nonassoc    ..  ...
 194 #  8 right       ?:
 195 #  7 right       = += -= *= etc.
 196 #  6 left        , =>
 197 #  5 nonassoc    list operators (rightward)
 198 #  4 right       not
 199 #  3 left        and
 200 #  2 left        or xor
 201 #  1             statement modifiers
 202 #  0             statement level
 203
 204 # Nonprinting characters with special meaning:
 205 # \cS - steal parens (see maybe_parens_unop)
 206 # \n - newline and indent
 207 # \t - increase indent
 208 # \b - decrease indent (`outdent')
 209 # \f - flush left (no indent)
 210 # \cK - kill following semicolon, if any
 211
 212 sub null {
 213     my $op = shift;
 214     return class($op) eq "NULL";
 215 }
 216
 217 sub todo {
 218     my $self = shift;
 219     my($cv, $is_form) = @_;
 220     my $seq;
 221     if (!null($cv->START) and is_state($cv->START)) {
 222         $seq = $cv->START->cop_seq;
 223     } else {
 224         $seq = 0;
 225     }
 226     push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
 227 }
 228
 229 sub next_todo {
 230     my $self = shift;
 231     my $ent = shift @{$self->{'subs_todo'}};
 232     my $cv = $ent->[1];
 233     my $gv = $cv->GV;
 234     my $name = $self->gv_name($gv);
 235     if ($ent->[2]) {
 236         return "format $name =\n"
 237             . $self->deparse_format($ent->[1]->FORM). "\n";
 238     } else {
 239         $self->{'subs_declared'}{$name} = 1;
 240         if ($name eq "BEGIN") {
 241             my $use_dec = $self->begin_is_use($cv);
 242             return $use_dec if defined ($use_dec);
 243         }
 244         return "sub $name " . $self->deparse_sub($cv);
 245     }
 246 }
 247
 248 # Return a "use" declaration for this BEGIN block, if appropriate
 249 sub begin_is_use {
 250     my ($self, $cv) = @_;
 251     my $root = $cv->ROOT;
 252 #require B::Debug;
 253 #B::walkoptree($cv->ROOT, "debug");
 254     my $lineseq = $root->first;
 255     return if $lineseq->name ne "lineseq";
 256
 257     my $req_op = $lineseq->first->sibling;
 258     return if $req_op->name ne "require";
 259
 260     my $module;
 261     if ($req_op->first->private & OPpCONST_BARE) {
 262         # Actually it should always be a bareword
 263         $module = $self->const_sv($req_op->first)->PV;
 264         $module =~ s[/][::]g;
 265         $module =~ s/.pm$//;
 266     }
 267     else {
 268         $module = const($self->const_sv($req_op->first));
 269     }
 270
 271     my $version;
 272     my $version_op = $req_op->sibling;
 273     return if class($version_op) eq "NULL";
 274     if ($version_op->name eq "lineseq") {
 275         # We have a version parameter; skip nextstate & pushmark
 276         my $constop = $version_op->first->next->next;
 277
 278         return unless $self->const_sv($constop)->PV eq $module;
 279         $constop = $constop->sibling;
 280
 281         $version = $self->const_sv($constop)->int_value;
 282         $constop = $constop->sibling;
 283         return if $constop->name ne "method_named";
 284         return if $self->const_sv($constop)->PV ne "VERSION";
 285     }
 286
 287     $lineseq = $version_op->sibling;
 288     return if $lineseq->name ne "lineseq";
 289     my $entersub = $lineseq->first->sibling;
 290     if ($entersub->name eq "stub") {
 291         return "use $module $version ();\n" if defined $version;
 292         return "use $module ();\n";
 293     }
 294     return if $entersub->name ne "entersub";
 295
 296     # See if there are import arguments
 297     my $args = '';
 298
 299     my $constop = $entersub->first->sibling; # Skip over pushmark
 300     return unless $self->const_sv($constop)->PV eq $module;
 301
 302     # Pull out the arguments
 303     for ($constop=$constop->sibling; $constop->name eq "const";
 304                 $constop = $constop->sibling) {
 305         $args .= ", " if length($args);
 306         $args .= $self->deparse($constop, 6);
 307     }
 308
 309     my $use = 'use';
 310     my $method_named = $constop;
 311     return if $method_named->name ne "method_named";
 312     my $method_name = $self->const_sv($method_named)->PV;
 313
 314     if ($method_name eq "unimport") {
 315         $use = 'no';
 316     }
 317
 318     # Certain pragmas are dealt with using hint bits,
 319     # so we ignore them here
 320     if ($module eq 'strict' || $module eq 'integer'
 321         || $module eq 'bytes') {
 322         return "";
 323     }
 324
 325     if (defined $version && length $args) {
 326         return "$use $module $version ($args);\n";
 327     } elsif (defined $version) {
 328         return "$use $module $version;\n";
 329     } elsif (length $args) {
 330         return "$use $module ($args);\n";
 331     } else {
 332         return "$use $module;\n";
 333     }
 334 }
 335
 336 sub walk_tree {
 337     my($op, $sub) = @_;
 338     $sub->($op);
 339     if ($op->flags & OPf_KIDS) {
 340         my $kid;
 341         for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
 342             walk_tree($kid, $sub);
 343         }
 344     }
 345 }
 346
 347 sub walk_sub {
 348     my $self = shift;
 349     my $cv = shift;
 350     my $op = $cv->ROOT;
 351     $op = shift if null $op;
 352     return if !$op or null $op;
 353     walk_tree($op, sub {
 354         my $op = shift;
 355         if ($op->name eq "gv") {
 356             my $gv = $self->gv_or_padgv($op);
 357             if ($op->next->name eq "entersub") {
 358                 return if $self->{'subs_done'}{$$gv}++;
 359                 return if class($gv->CV) eq "SPECIAL";
 360                 $self->todo($gv->CV, 0);
 361                 $self->walk_sub($gv->CV);
 362             } elsif ($op->next->name eq "enterwrite"
 363                      or ($op->next->name eq "rv2gv"
 364                          and $op->next->next->name eq "enterwrite")) {
 365                 return if $self->{'forms_done'}{$$gv}++;
 366                 return if class($gv->FORM) eq "SPECIAL";
 367                 $self->todo($gv->FORM, 1);
 368                 $self->walk_sub($gv->FORM);
 369             }
 370         }
 371     });
 372 }
 373
 374 sub stash_subs {
 375     my ($self, $pack) = @_;
 376     my (@ret, $stash);
 377     if (!defined $pack) {
 378         $pack = '';
 379         $stash = \%::;
 380     }
 381     else {
 382         $pack =~ s/(::)?$/::/;
 383         no strict 'refs';
 384         $stash = \%$pack;
 385     }
 386     my %stash = svref_2object($stash)->ARRAY;
 387     while (my ($key, $val) = each %stash) {
 388         next if $key eq 'main::';       # avoid infinite recursion
 389         next if $key eq 'B::';          # don't automatically scan B
 390         my $class = class($val);
 391         if ($class eq "PV") {
 392             # Just a prototype
 393             push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
 394         } elsif ($class eq "IV") {
 395             # Just a name
 396             push @{$self->{'protos_todo'}}, [$pack . $key, undef];
 397         } elsif ($class eq "GV") {
 398             if (class(my $cv = $val->CV) ne "SPECIAL") {
 399                 next unless $cv->FILE eq $0 || $self->{'files'}{$cv->FILE};
 400                 next if $self->{'subs_done'}{$$val}++;
 401                 $self->todo($val->CV, 0);
 402                 $self->walk_sub($val->CV);
 403             }
 404             if (class($val->FORM) ne "SPECIAL") {
 405                 next if $self->{'forms_done'}{$$val}++;
 406                 $self->todo($val->FORM, 1);
 407                 $self->walk_sub($val->FORM);
 408             }
 409             if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
 410                 $self->stash_subs($pack . $key);
 411             }
 412         }
 413     }
 414 }
 415
 416 sub print_protos {
 417     my $self = shift;
 418     my $ar;
 419     my @ret;
 420     foreach $ar (@{$self->{'protos_todo'}}) {
 421         my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
 422         push @ret, "sub " . $ar->[0] .  "$proto;\n";
 423     }
 424     delete $self->{'protos_todo'};
 425     return @ret;
 426 }
 427
 428 sub style_opts {
 429     my $self = shift;
 430     my $opts = shift;
 431     my $opt;
 432     while (length($opt = substr($opts, 0, 1))) {
 433         if ($opt eq "C") {
 434             $self->{'cuddle'} = " ";
 435             $opts = substr($opts, 1);
 436         } elsif ($opt eq "i") {
 437             $opts =~ s/^i(\d+)//;
 438             $self->{'indent_size'} = $1;
 439         } elsif ($opt eq "T") {
 440             $self->{'use_tabs'} = 1;
 441             $opts = substr($opts, 1);
 442         } elsif ($opt eq "v") {
 443             $opts =~ s/^v([^.]*)(.|$)//;
 444             $self->{'ex_const'} = $1;
 445         }
 446     }
 447 }
 448
 449 sub new {
 450     my $class = shift;
 451     my $self = bless {}, $class;
 452     $self->{'subs_todo'} = [];
 453     $self->{'files'} = {};
 454     $self->{'curstash'} = "main";
 455     $self->{'curcop'} = undef;
 456     $self->{'cuddle'} = "\n";
 457     $self->{'indent_size'} = 4;
 458     $self->{'use_tabs'} = 0;
 459     $self->{'expand'} = 0;
 460     $self->{'unquote'} = 0;
 461     $self->{'linenums'} = 0;
 462     $self->{'parens'} = 0;
 463     $self->{'ex_const'} = "'???'";
 464
 465     $self->{'ambient_arybase'} = 0;
 466     $self->{'ambient_warnings'} = "\0"x12;
 467     $self->{'ambient_hints'} = 0;
 468     $self->init();
 469
 470     while (my $arg = shift @_) {
 471         if ($arg =~ /^-f(.*)/) {
 472             $self->{'files'}{$1} = 1;
 473         } elsif ($arg eq "-p") {
 474             $self->{'parens'} = 1;
 475         } elsif ($arg eq "-l") {
 476             $self->{'linenums'} = 1;
 477         } elsif ($arg eq "-q") {
 478             $self->{'unquote'} = 1;
 479         } elsif (substr($arg, 0, 2) eq "-s") {
 480             $self->style_opts(substr $arg, 2);
 481         } elsif ($arg =~ /^-x(\d)$/) {
 482             $self->{'expand'} = $1;
 483         }
 484     }
 485     return $self;
 486 }
 487
 488 sub WARN_MASK () {
 489     # Mask out the bits that C<use vars> uses
 490     $warnings::Bits{all} | $warnings::DeadBits{all};
 491 }
 492
 493 # Initialise the contextual information, either from
 494 # defaults provided with the ambient_pragmas method,
 495 # or from perl's own defaults otherwise.
 496 sub init {
 497     my $self = shift;
 498
 499     $self->{'arybase'}  = $self->{'ambient_arybase'};
 500     $self->{'warnings'} = $self->{'ambient_warnings'} & WARN_MASK;
 501     $self->{'hints'}    = $self->{'ambient_hints'} & 0xFF;
 502
 503     # also a convenient place to clear out subs_declared
 504     delete $self->{'subs_declared'};
 505 }
 506
 507 sub compile {
 508     my(@args) = @_;
 509     return sub {
 510         my $self = B::Deparse->new(@args);
 511         my @BEGINs  = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
 512         my @INITs   = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
 513         my @ENDs    = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
 514         for my $block (@BEGINs, @INITs, @ENDs) {
 515             if ($block->FILE eq $0 || $self->{'files'}{$block->FILE}) {
 516                 $self->todo($block, 0);
 517                 $self->walk_sub($block);
 518             }
 519         }
 520         $self->stash_subs();
 521         $self->{'curcv'} = main_cv;
 522         $self->walk_sub(main_cv, main_start);
 523         print $self->print_protos;
 524         @{$self->{'subs_todo'}} =
 525           sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
 526         print $self->indent($self->deparse(main_root, 0)), "\n"
 527           unless null main_root;
 528         my @text;
 529         while (scalar(@{$self->{'subs_todo'}})) {
 530             push @text, $self->next_todo;
 531         }
 532         print $self->indent(join("", @text)), "\n" if @text;
 533     }
 534 }
 535
 536 sub coderef2text {
 537     my $self = shift;
 538     my $sub = shift;
 539     croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
 540
 541     $self->init();
 542     return $self->indent($self->deparse_sub(svref_2object($sub)));
 543 }
 544
 545 sub ambient_pragmas {
 546     my $self = shift;
 547     my ($arybase, $hint_bits, $warning_bits) = (0, 0, "\0"x12);
 548
 549     while (@_ > 1) {
 550         my $name = shift();
 551         my $val  = shift();
 552
 553         if ($name eq 'strict') {
 554             require strict;
 555
 556             if ($val eq 'none') {
 557                 $hint_bits &= ~strict::bits(qw/refs subs vars/);
 558                 next();
 559             }
 560
 561             my @names;
 562             if ($val eq "all") {
 563                 @names = qw/refs subs vars/;
 564             }
 565             elsif (ref $val) {
 566                 @names = @$val;
 567             }
 568             else {
 569                 @names = split' ', $val;
 570             }
 571             $hint_bits |= strict::bits(@names);
 572         }
 573
 574         elsif ($name eq '$[') {
 575             $arybase = $val;
 576         }
 577
 578         elsif ($name eq 'integer'
 579             || $name eq 'bytes'
 580             || $name eq 'utf8') {
 581             require "$name.pm";
 582             if ($val) {
 583                 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
 584             }
 585             else {
 586                 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
 587             }
 588         }
 589
 590         elsif ($name eq 're') {
 591             require re;
 592             if ($val eq 'none') {
 593                 $hint_bits &= ~re::bits(qw/taint eval asciirange/);
 594                 next();
 595             }
 596
 597             my @names;
 598             if ($val eq 'all') {
 599                 @names = qw/taint eval asciirange/;
 600             }
 601             elsif (ref $val) {
 602                 @names = @$val;
 603             }
 604             else {
 605                 @names = split' ',$val;
 606             }
 607             $hint_bits |= re::bits(@names);
 608         }
 609
 610         elsif ($name eq 'warnings') {
 611             if ($val eq 'none') {
 612                 $warning_bits = "\0"x12;
 613                 next();
 614             }
 615
 616             my @names;
 617             if (ref $val) {
 618                 @names = @$val;
 619             }
 620             else {
 621                 @names = split/\s+/, $val;
 622             }
 623
 624             $warning_bits |= warnings::bits(@names);
 625         }
 626
 627         elsif ($name eq 'warning_bits') {
 628             $warning_bits = $val;
 629         }
 630
 631         elsif ($name eq 'hint_bits') {
 632             $hint_bits = $val;
 633         }
 634
 635         else {
 636             croak "Unknown pragma type: $name";
 637         }
 638     }
 639     if (@_) {
 640         croak "The ambient_pragmas method expects an even number of args";
 641     }
 642
 643     $self->{'ambient_arybase'} = $arybase;
 644     $self->{'ambient_warnings'} = $warning_bits;
 645     $self->{'ambient_hints'} = $hint_bits;
 646 }
 647
 648 sub deparse {
 649     my $self = shift;
 650     my($op, $cx) = @_;
 651
 652     Carp::confess("Null op in deparse") if !defined($op)
 653                                         || class($op) eq "NULL";
 654     my $meth = "pp_" . $op->name;
 655     return $self->$meth($op, $cx);
 656 }
 657
 658 sub indent {
 659     my $self = shift;
 660     my $txt = shift;
 661     my @lines = split(/\n/, $txt);
 662     my $leader = "";
 663     my $level = 0;
 664     my $line;
 665     for $line (@lines) {
 666         my $cmd = substr($line, 0, 1);
 667         if ($cmd eq "\t" or $cmd eq "\b") {
 668             $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
 669             if ($self->{'use_tabs'}) {
 670                 $leader = "\t" x ($level / 8) . " " x ($level % 8);
 671             } else {
 672                 $leader = " " x $level;
 673             }
 674             $line = substr($line, 1);
 675         }
 676         if (substr($line, 0, 1) eq "\f") {
 677             $line = substr($line, 1); # no indent
 678         } else {
 679             $line = $leader . $line;
 680         }
 681         $line =~ s/\cK;?//g;
 682     }
 683     return join("\n", @lines);
 684 }
 685
 686 sub deparse_sub {
 687     my $self = shift;
 688     my $cv = shift;
 689     my $proto = "";
 690 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
 691     local $self->{'curcop'} = $self->{'curcop'};
 692     if ($cv->FLAGS & SVf_POK) {
 693         $proto = "(". $cv->PV . ") ";
 694     }
 695     if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
 696         $proto .= ": ";
 697         $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
 698         $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
 699         $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
 700     }
 701
 702     local($self->{'curcv'}) = $cv;
 703     local(@$self{qw'curstash warnings hints'})
 704                 = @$self{qw'curstash warnings hints'};
 705     if (not null $cv->ROOT) {
 706         # skip leavesub
 707         return $proto . "{\n\t" .
 708             $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
 709     }
 710     my $sv = $cv->const_sv;
 711     if ($$sv) {
 712         # uh-oh. inlinable sub... format it differently
 713         return $proto . "{ " . const($sv) . " }\n";
 714     } else { # XSUB? (or just a declaration)
 715         return "$proto;\n";
 716     }
 717 }
 718
 719 sub deparse_format {
 720     my $self = shift;
 721     my $form = shift;
 722     my @text;
 723     local($self->{'curcv'}) = $form;
 724     local(@$self{qw'curstash warnings hints'})
 725                 = @$self{'curstash warnings hints'};
 726     my $op = $form->ROOT;
 727     my $kid;
 728     $op = $op->first->first; # skip leavewrite, lineseq
 729     while (not null $op) {
 730         $op = $op->sibling; # skip nextstate
 731         my @exprs;
 732         $kid = $op->first->sibling; # skip pushmark
 733         push @text, $self->const_sv($kid)->PV;
 734         $kid = $kid->sibling;
 735         for (; not null $kid; $kid = $kid->sibling) {
 736             push @exprs, $self->deparse($kid, 0);
 737         }
 738         push @text, join(", ", @exprs)."\n" if @exprs;
 739         $op = $op->sibling;
 740     }
 741     return join("", @text) . ".";
 742 }
 743
 744 sub is_scope {
 745     my $op = shift;
 746     return $op->name eq "leave" || $op->name eq "scope"
 747       || $op->name eq "lineseq"
 748         || ($op->name eq "null" && class($op) eq "UNOP"
 749             && (is_scope($op->first) || $op->first->name eq "enter"));
 750 }
 751
 752 sub is_state {
 753     my $name = $_[0]->name;
 754     return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
 755 }
 756
 757 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
 758     my $op = shift;
 759     return (!null($op) and null($op->sibling)
 760             and $op->name eq "null" and class($op) eq "UNOP"
 761             and (($op->first->name =~ /^(and|or)$/
 762                   and $op->first->first->sibling->name eq "lineseq")
 763                  or ($op->first->name eq "lineseq"
 764                      and not null $op->first->first->sibling
 765                      and $op->first->first->sibling->name eq "unstack")
 766                  ));
 767 }
 768
 769 sub is_scalar {
 770     my $op = shift;
 771     return ($op->name eq "rv2sv" or
 772             $op->name eq "padsv" or
 773             $op->name eq "gv" or # only in array/hash constructs
 774             $op->flags & OPf_KIDS && !null($op->first)
 775               && $op->first->name eq "gvsv");
 776 }
 777
 778 sub maybe_parens {
 779     my $self = shift;
 780     my($text, $cx, $prec) = @_;
 781     if ($prec < $cx              # unary ops nest just fine
 782         or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
 783         or $self->{'parens'})
 784     {
 785         $text = "($text)";
 786         # In a unop, let parent reuse our parens; see maybe_parens_unop
 787         $text = "\cS" . $text if $cx == 16;
 788         return $text;
 789     } else {
 790         return $text;
 791     }
 792 }
 793
 794 # same as above, but get around the `if it looks like a function' rule
 795 sub maybe_parens_unop {
 796     my $self = shift;
 797     my($name, $kid, $cx) = @_;
 798     if ($cx > 16 or $self->{'parens'}) {
 799         return "$name(" . $self->deparse($kid, 1) . ")";
 800     } else {
 801         $kid = $self->deparse($kid, 16);
 802         if (substr($kid, 0, 1) eq "\cS") {
 803             # use kid's parens
 804             return $name . substr($kid, 1);
 805         } elsif (substr($kid, 0, 1) eq "(") {
 806             # avoid looks-like-a-function trap with extra parens
 807             # (`+' can lead to ambiguities)
 808             return "$name(" . $kid  . ")";
 809         } else {
 810             return "$name $kid";
 811         }
 812     }
 813 }
 814
 815 sub maybe_parens_func {
 816     my $self = shift;
 817     my($func, $text, $cx, $prec) = @_;
 818     if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
 819         return "$func($text)";
 820     } else {
 821         return "$func $text";
 822     }
 823 }
 824
 825 sub maybe_local {
 826     my $self = shift;
 827     my($op, $cx, $text) = @_;
 828     if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
 829         if (want_scalar($op)) {
 830             return "local $text";
 831         } else {
 832             return $self->maybe_parens_func("local", $text, $cx, 16);
 833         }
 834     } else {
 835         return $text;
 836     }
 837 }
 838
 839 sub maybe_targmy {
 840     my $self = shift;
 841     my($op, $cx, $func, @args) = @_;
 842     if ($op->private & OPpTARGET_MY) {
 843         my $var = $self->padname($op->targ);
 844         my $val = $func->($self, $op, 7, @args);
 845         return $self->maybe_parens("$var = $val", $cx, 7);
 846     } else {
 847         return $func->($self, $op, $cx, @args);
 848     }
 849 }
 850
 851 sub padname_sv {
 852     my $self = shift;
 853     my $targ = shift;
 854     return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
 855 }
 856
 857 sub maybe_my {
 858     my $self = shift;
 859     my($op, $cx, $text) = @_;
 860     if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
 861         if (want_scalar($op)) {
 862             return "my $text";
 863         } else {
 864             return $self->maybe_parens_func("my", $text, $cx, 16);
 865         }
 866     } else {
 867         return $text;
 868     }
 869 }
 870
 871 # The following OPs don't have functions:
 872
 873 # pp_padany -- does not exist after parsing
 874 # pp_rcatline -- does not exist
 875
 876 sub pp_enter { # see also leave
 877     cluck "unexpected OP_ENTER";
 878     return "XXX";
 879 }
 880
 881 sub pp_pushmark { # see also list
 882     cluck "unexpected OP_PUSHMARK";
 883     return "XXX";
 884 }
 885
 886 sub pp_leavesub { # see also deparse_sub
 887     cluck "unexpected OP_LEAVESUB";
 888     return "XXX";
 889 }
 890
 891 sub pp_leavewrite { # see also deparse_format
 892     cluck "unexpected OP_LEAVEWRITE";
 893     return "XXX";
 894 }
 895
 896 sub pp_method { # see also entersub
 897     cluck "unexpected OP_METHOD";
 898     return "XXX";
 899 }
 900
 901 sub pp_regcmaybe { # see also regcomp
 902     cluck "unexpected OP_REGCMAYBE";
 903     return "XXX";
 904 }
 905
 906 sub pp_regcreset { # see also regcomp
 907     cluck "unexpected OP_REGCRESET";
 908     return "XXX";
 909 }
 910
 911 sub pp_substcont { # see also subst
 912     cluck "unexpected OP_SUBSTCONT";
 913     return "XXX";
 914 }
 915
 916 sub pp_grepstart { # see also grepwhile
 917     cluck "unexpected OP_GREPSTART";
 918     return "XXX";
 919 }
 920
 921 sub pp_mapstart { # see also mapwhile
 922     cluck "unexpected OP_MAPSTART";
 923     return "XXX";
 924 }
 925
 926 sub pp_flip { # see also flop
 927     cluck "unexpected OP_FLIP";
 928     return "XXX";
 929 }
 930
 931 sub pp_iter { # see also leaveloop
 932     cluck "unexpected OP_ITER";
 933     return "XXX";
 934 }
 935
 936 sub pp_enteriter { # see also leaveloop
 937     cluck "unexpected OP_ENTERITER";
 938     return "XXX";
 939 }
 940
 941 sub pp_enterloop { # see also leaveloop
 942     cluck "unexpected OP_ENTERLOOP";
 943     return "XXX";
 944 }
 945
 946 sub pp_leaveeval { # see also entereval
 947     cluck "unexpected OP_LEAVEEVAL";
 948     return "XXX";
 949 }
 950
 951 sub pp_entertry { # see also leavetry
 952     cluck "unexpected OP_ENTERTRY";
 953     return "XXX";
 954 }
 955
 956 sub lineseq {
 957     my $self = shift;
 958     my(@ops) = @_;
 959     my($expr, @exprs);
 960     for (my $i = 0; $i < @ops; $i++) {
 961         $expr = "";
 962         if (is_state $ops[$i]) {
 963             $expr = $self->deparse($ops[$i], 0);
 964             $i++;
 965             last if $i > $#ops;
 966         }
 967         if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and
 968             $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3)
 969         {
 970             push @exprs, $expr . $self->for_loop($ops[$i], 0);
 971             $i++;
 972             next;
 973         }
 974         $expr .= $self->deparse($ops[$i], 0);
 975         push @exprs, $expr if length $expr;
 976     }
 977     for(@exprs[0..@exprs-1]) { s/;\n\z// }
 978     return join(";\n", @exprs);
 979 }
 980
 981 sub scopeop {
 982     my($real_block, $self, $op, $cx) = @_;
 983     my $kid;
 984     my @kids;
 985
 986     local(@$self{qw'curstash warnings hints'})
 987                 = @$self{qw'curstash warnings hints'} if $real_block;
 988     if ($real_block) {
 989         $kid = $op->first->sibling; # skip enter
 990         if (is_miniwhile($kid)) {
 991             my $top = $kid->first;
 992             my $name = $top->name;
 993             if ($name eq "and") {
 994                 $name = "while";
 995             } elsif ($name eq "or") {
 996                 $name = "until";
 997             } else { # no conditional -> while 1 or until 0
 998                 return $self->deparse($top->first, 1) . " while 1";
 999             }
1000             my $cond = $top->first;
1001             my $body = $cond->sibling->first; # skip lineseq
1002             $cond = $self->deparse($cond, 1);
1003             $body = $self->deparse($body, 1);
1004             return "$body $name $cond";
1005         }
1006     } else {
1007         $kid = $op->first;
1008     }
1009     for (; !null($kid); $kid = $kid->sibling) {
1010         push @kids, $kid;
1011     }
1012     if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
1013         return "do { " . $self->lineseq(@kids) . " }";
1014     } else {
1015         my $lineseq = $self->lineseq(@kids);
1016         return (length ($lineseq) ? "$lineseq;" : "");
1017     }
1018 }
1019
1020 sub pp_scope { scopeop(0, @_); }
1021 sub pp_lineseq { scopeop(0, @_); }
1022 sub pp_leave { scopeop(1, @_); }
1023
1024 # The BEGIN {} is used here because otherwise this code isn't executed
1025 # when you run B::Deparse on itself.
1026 my %globalnames;
1027 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1028             "ENV", "ARGV", "ARGVOUT", "_"); }
1029
1030 sub gv_name {
1031     my $self = shift;
1032     my $gv = shift;
1033 Carp::confess() if $gv->isa("B::CV");
1034     my $stash = $gv->STASH->NAME;
1035     my $name = $gv->SAFENAME;
1036     if ($stash eq $self->{'curstash'} or $globalnames{$name}
1037         or $name =~ /^[^A-Za-z_]/)
1038     {
1039         $stash = "";
1040     } else {
1041         $stash = $stash . "::";
1042     }
1043     if ($name =~ /^\^../) {
1044         $name = "{$name}";       # ${^WARNING_BITS} etc
1045     }
1046     return $stash . $name;
1047 }
1048
1049 # Recurses down the tree, looking for a COP
1050 sub find_cop {
1051     my ($self, $op) = @_;
1052     if ($op->flags & OPf_KIDS) {
1053         for (my $o=$op->first; $$o; $o=$o->sibling) {
1054             return $o if is_state($o);
1055             my $r = $self->find_cop($o);
1056             return $r if defined $r;
1057         }
1058     }
1059     return undef;
1060 }
1061
1062 # Returns a list of subs which should be inserted before the COP
1063 sub cop_subs {
1064     my ($self, $op, $out_seq) = @_;
1065     my $seq = $op->cop_seq;
1066     # If we have nephews, then our sequence number indicates
1067     # the cop_seq of the end of some sort of scope.
1068     if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1069         and my $ncop = $self->find_cop($op->sibling)) {
1070         $seq = $ncop->cop_seq;
1071     }
1072     $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1073     return $self->seq_subs($seq);
1074 }
1075
1076 sub seq_subs {
1077     my ($self, $seq) = @_;
1078     my @text;
1079 #push @text, "# ($seq)\n";
1080
1081     while (scalar(@{$self->{'subs_todo'}})
1082            and $seq > $self->{'subs_todo'}[0][0]) {
1083         push @text, $self->next_todo;
1084     }
1085     return @text;
1086 }
1087
1088 # Notice how subs and formats are inserted between statements here;
1089 # also $[ assignments and pragmas.
1090 sub pp_nextstate {
1091     my $self = shift;
1092     my($op, $cx) = @_;
1093     $self->{'curcop'} = $op;
1094     my @text;
1095     @text = $op->label . ": " if $op->label;
1096 #push @text, "# ", $op->cop_seq, "\n";
1097     push @text, $self->cop_subs($op);
1098     my $stash = $op->stashpv;
1099     if ($stash ne $self->{'curstash'}) {
1100         push @text, "package $stash;\n";
1101         $self->{'curstash'} = $stash;
1102     }
1103     if ($self->{'linenums'}) {
1104         push @text, "\f#line " . $op->line .
1105           ' "' . $op->file, qq'"\n';
1106     }
1107
1108     if ($self->{'arybase'} != $op->arybase) {
1109         push @text, '$[ = '. $op->arybase .";\n";
1110         $self->{'arybase'} = $op->arybase;
1111     }
1112
1113     my $warnings = $op->warnings;
1114     my $warning_bits;
1115     if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1116         $warning_bits = $warnings::Bits{"all"};
1117     }
1118     elsif ($warnings->isa("B::SPECIAL")) {
1119         $warning_bits = "\0"x12;
1120     }
1121     else {
1122         $warning_bits = $warnings->PV & WARN_MASK;
1123     }
1124
1125     if ($self->{'warnings'} ne $warning_bits) {
1126         push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1127         $self->{'warnings'} = $warning_bits;
1128     }
1129
1130     if ($self->{'hints'} != $op->private) {
1131         push @text, declare_hints($self->{'hints'}, $op->private);
1132         $self->{'hints'} = $op->private;
1133     }
1134
1135     return join("", @text);
1136 }
1137
1138 sub declare_warnings {
1139     my ($from, $to) = @_;
1140     if ($to eq warnings::bits("all")) {
1141         return "use warnings;\n";
1142     }
1143     elsif ($to eq "\0"x12) {
1144         return "no warnings;\n";
1145     }
1146     return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n";
1147 }
1148
1149 sub declare_hints {
1150     my ($from, $to) = @_;
1151     my $bits = $to;
1152     return sprintf "BEGIN {\$^H &= ~0xFF; \$^H |= %x}\n", $bits;
1153 }
1154
1155 sub pp_dbstate { pp_nextstate(@_) }
1156 sub pp_setstate { pp_nextstate(@_) }
1157
1158 sub pp_unstack { return "" } # see also leaveloop
1159
1160 sub baseop {
1161     my $self = shift;
1162     my($op, $cx, $name) = @_;
1163     return $name;
1164 }
1165
1166 sub pp_stub { baseop(@_, "()") }
1167 sub pp_wantarray { baseop(@_, "wantarray") }
1168 sub pp_fork { baseop(@_, "fork") }
1169 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1170 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1171 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1172 sub pp_tms { baseop(@_, "times") }
1173 sub pp_ghostent { baseop(@_, "gethostent") }
1174 sub pp_gnetent { baseop(@_, "getnetent") }
1175 sub pp_gprotoent { baseop(@_, "getprotoent") }
1176 sub pp_gservent { baseop(@_, "getservent") }
1177 sub pp_ehostent { baseop(@_, "endhostent") }
1178 sub pp_enetent { baseop(@_, "endnetent") }
1179 sub pp_eprotoent { baseop(@_, "endprotoent") }
1180 sub pp_eservent { baseop(@_, "endservent") }
1181 sub pp_gpwent { baseop(@_, "getpwent") }
1182 sub pp_spwent { baseop(@_, "setpwent") }
1183 sub pp_epwent { baseop(@_, "endpwent") }
1184 sub pp_ggrent { baseop(@_, "getgrent") }
1185 sub pp_sgrent { baseop(@_, "setgrent") }
1186 sub pp_egrent { baseop(@_, "endgrent") }
1187 sub pp_getlogin { baseop(@_, "getlogin") }
1188
1189 sub POSTFIX () { 1 }
1190
1191 # I couldn't think of a good short name, but this is the category of
1192 # symbolic unary operators with interesting precedence
1193
1194 sub pfixop {
1195     my $self = shift;
1196     my($op, $cx, $name, $prec, $flags) = (@_, 0);
1197     my $kid = $op->first;
1198     $kid = $self->deparse($kid, $prec);
1199     return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1200                                $cx, $prec);
1201 }
1202
1203 sub pp_preinc { pfixop(@_, "++", 23) }
1204 sub pp_predec { pfixop(@_, "--", 23) }
1205 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1206 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1207 sub pp_i_preinc { pfixop(@_, "++", 23) }
1208 sub pp_i_predec { pfixop(@_, "--", 23) }
1209 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1210 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1211 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1212
1213 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1214 sub real_negate {
1215     my $self = shift;
1216     my($op, $cx) = @_;
1217     if ($op->first->name =~ /^(i_)?negate$/) {
1218         # avoid --$x
1219         $self->pfixop($op, $cx, "-", 21.5);
1220     } else {
1221         $self->pfixop($op, $cx, "-", 21);
1222     }
1223 }
1224 sub pp_i_negate { pp_negate(@_) }
1225
1226 sub pp_not {
1227     my $self = shift;
1228     my($op, $cx) = @_;
1229     if ($cx <= 4) {
1230         $self->pfixop($op, $cx, "not ", 4);
1231     } else {
1232         $self->pfixop($op, $cx, "!", 21);
1233     }
1234 }
1235
1236 sub unop {
1237     my $self = shift;
1238     my($op, $cx, $name) = @_;
1239     my $kid;
1240     if ($op->flags & OPf_KIDS) {
1241         $kid = $op->first;
1242         return $self->maybe_parens_unop($name, $kid, $cx);
1243     } else {
1244         return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");
1245     }
1246 }
1247
1248 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1249 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1250 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1251 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1252 sub pp_defined { unop(@_, "defined") }
1253 sub pp_undef { unop(@_, "undef") }
1254 sub pp_study { unop(@_, "study") }
1255 sub pp_ref { unop(@_, "ref") }
1256 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1257
1258 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1259 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1260 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1261 sub pp_srand { unop(@_, "srand") }
1262 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1263 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1264 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1265 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1266 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1267 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1268 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1269
1270 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1271 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1272 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1273
1274 sub pp_each { unop(@_, "each") }
1275 sub pp_values { unop(@_, "values") }
1276 sub pp_keys { unop(@_, "keys") }
1277 sub pp_pop { unop(@_, "pop") }
1278 sub pp_shift { unop(@_, "shift") }
1279
1280 sub pp_caller { unop(@_, "caller") }
1281 sub pp_reset { unop(@_, "reset") }
1282 sub pp_exit { unop(@_, "exit") }
1283 sub pp_prototype { unop(@_, "prototype") }
1284
1285 sub pp_close { unop(@_, "close") }
1286 sub pp_fileno { unop(@_, "fileno") }
1287 sub pp_umask { unop(@_, "umask") }
1288 sub pp_untie { unop(@_, "untie") }
1289 sub pp_tied { unop(@_, "tied") }
1290 sub pp_dbmclose { unop(@_, "dbmclose") }
1291 sub pp_getc { unop(@_, "getc") }
1292 sub pp_eof { unop(@_, "eof") }
1293 sub pp_tell { unop(@_, "tell") }
1294 sub pp_getsockname { unop(@_, "getsockname") }
1295 sub pp_getpeername { unop(@_, "getpeername") }
1296
1297 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1298 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1299 sub pp_readlink { unop(@_, "readlink") }
1300 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1301 sub pp_readdir { unop(@_, "readdir") }
1302 sub pp_telldir { unop(@_, "telldir") }
1303 sub pp_rewinddir { unop(@_, "rewinddir") }
1304 sub pp_closedir { unop(@_, "closedir") }
1305 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1306 sub pp_localtime { unop(@_, "localtime") }
1307 sub pp_gmtime { unop(@_, "gmtime") }
1308 sub pp_alarm { unop(@_, "alarm") }
1309 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1310
1311 sub pp_dofile { unop(@_, "do") }
1312 sub pp_entereval { unop(@_, "eval") }
1313
1314 sub pp_ghbyname { unop(@_, "gethostbyname") }
1315 sub pp_gnbyname { unop(@_, "getnetbyname") }
1316 sub pp_gpbyname { unop(@_, "getprotobyname") }
1317 sub pp_shostent { unop(@_, "sethostent") }
1318 sub pp_snetent { unop(@_, "setnetent") }
1319 sub pp_sprotoent { unop(@_, "setprotoent") }
1320 sub pp_sservent { unop(@_, "setservent") }
1321 sub pp_gpwnam { unop(@_, "getpwnam") }
1322 sub pp_gpwuid { unop(@_, "getpwuid") }
1323 sub pp_ggrnam { unop(@_, "getgrnam") }
1324 sub pp_ggrgid { unop(@_, "getgrgid") }
1325
1326 sub pp_lock { unop(@_, "lock") }
1327
1328 sub pp_exists {
1329     my $self = shift;
1330     my($op, $cx) = @_;
1331     my $arg;
1332     if ($op->private & OPpEXISTS_SUB) {
1333         # Checking for the existence of a subroutine
1334         return $self->maybe_parens_func("exists",
1335                                 $self->pp_rv2cv($op->first, 16), $cx, 16);
1336     }
1337     if ($op->flags & OPf_SPECIAL) {
1338         # Array element, not hash element
1339         return $self->maybe_parens_func("exists",
1340                                 $self->pp_aelem($op->first, 16), $cx, 16);
1341     }
1342     return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1343                                     $cx, 16);
1344 }
1345
1346 sub pp_delete {
1347     my $self = shift;
1348     my($op, $cx) = @_;
1349     my $arg;
1350     if ($op->private & OPpSLICE) {
1351         if ($op->flags & OPf_SPECIAL) {
1352             # Deleting from an array, not a hash
1353             return $self->maybe_parens_func("delete",
1354                                         $self->pp_aslice($op->first, 16),
1355                                         $cx, 16);
1356         }
1357         return $self->maybe_parens_func("delete",
1358                                         $self->pp_hslice($op->first, 16),
1359                                         $cx, 16);
1360     } else {
1361         if ($op->flags & OPf_SPECIAL) {
1362             # Deleting from an array, not a hash
1363             return $self->maybe_parens_func("delete",
1364                                         $self->pp_aelem($op->first, 16),
1365                                         $cx, 16);
1366         }
1367         return $self->maybe_parens_func("delete",
1368                                         $self->pp_helem($op->first, 16),
1369                                         $cx, 16);
1370     }
1371 }
1372
1373 sub pp_require {
1374     my $self = shift;
1375     my($op, $cx) = @_;
1376     if (class($op) eq "UNOP" and $op->first->name eq "const"
1377         and $op->first->private & OPpCONST_BARE)
1378     {
1379         my $name = $self->const_sv($op->first)->PV;
1380         $name =~ s[/][::]g;
1381         $name =~ s/\.pm//g;
1382         return "require $name";
1383     } else {
1384         $self->unop($op, $cx, "require");
1385     }
1386 }
1387
1388 sub pp_scalar {
1389     my $self = shift;
1390     my($op, $cv) = @_;
1391     my $kid = $op->first;
1392     if (not null $kid->sibling) {
1393         # XXX Was a here-doc
1394         return $self->dquote($op);
1395     }
1396     $self->unop(@_, "scalar");
1397 }
1398
1399
1400 sub padval {
1401     my $self = shift;
1402     my $targ = shift;
1403     #cluck "curcv was undef" unless $self->{curcv};
1404     return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1405 }
1406
1407 sub pp_refgen {
1408     my $self = shift;
1409     my($op, $cx) = @_;
1410     my $kid = $op->first;
1411     if ($kid->name eq "null") {
1412         $kid = $kid->first;
1413         if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1414             my($pre, $post) = @{{"anonlist" => ["[","]"],
1415                                  "anonhash" => ["{","}"]}->{$kid->name}};
1416             my($expr, @exprs);
1417             $kid = $kid->first->sibling; # skip pushmark
1418             for (; !null($kid); $kid = $kid->sibling) {
1419                 $expr = $self->deparse($kid, 6);
1420                 push @exprs, $expr;
1421             }
1422             return $pre . join(", ", @exprs) . $post;
1423         } elsif (!null($kid->sibling) and
1424                  $kid->sibling->name eq "anoncode") {
1425             return "sub " .
1426                 $self->deparse_sub($self->padval($kid->sibling->targ));
1427         } elsif ($kid->name eq "pushmark") {
1428             my $sib_name = $kid->sibling->name;
1429             if ($sib_name =~ /^(pad|rv2)[ah]v$/
1430                 and not $kid->sibling->flags & OPf_REF)
1431             {
1432                 # The @a in \(@a) isn't in ref context, but only when the
1433                 # parens are there.
1434                 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1435             } elsif ($sib_name eq 'entersub') {
1436                 my $text = $self->deparse($kid->sibling, 1);
1437                 # Always show parens for \(&func()), but only with -p otherwise
1438                 $text = "($text)" if $self->{'parens'}
1439                                  or $kid->sibling->private & OPpENTERSUB_AMPER;
1440                 return "\\$text";
1441             }
1442         }
1443     }
1444     $self->pfixop($op, $cx, "\\", 20);
1445 }
1446
1447 sub pp_srefgen { pp_refgen(@_) }
1448
1449 sub pp_readline {
1450     my $self = shift;
1451     my($op, $cx) = @_;
1452     my $kid = $op->first;
1453     $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1454     return "<" . $self->deparse($kid, 1) . ">";
1455 }
1456
1457 # Unary operators that can occur as pseudo-listops inside double quotes
1458 sub dq_unop {
1459     my $self = shift;
1460     my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1461     my $kid;
1462     if ($op->flags & OPf_KIDS) {
1463        $kid = $op->first;
1464        # If there's more than one kid, the first is an ex-pushmark.
1465        $kid = $kid->sibling if not null $kid->sibling;
1466        return $self->maybe_parens_unop($name, $kid, $cx);
1467     } else {
1468        return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");
1469     }
1470 }
1471
1472 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1473 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1474 sub pp_uc { dq_unop(@_, "uc") }
1475 sub pp_lc { dq_unop(@_, "lc") }
1476 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1477
1478 sub loopex {
1479     my $self = shift;
1480     my ($op, $cx, $name) = @_;
1481     if (class($op) eq "PVOP") {
1482         return "$name " . $op->pv;
1483     } elsif (class($op) eq "OP") {
1484         return $name;
1485     } elsif (class($op) eq "UNOP") {
1486         # Note -- loop exits are actually exempt from the
1487         # looks-like-a-func rule, but a few extra parens won't hurt
1488         return $self->maybe_parens_unop($name, $op->first, $cx);
1489     }
1490 }
1491
1492 sub pp_last { loopex(@_, "last") }
1493 sub pp_next { loopex(@_, "next") }
1494 sub pp_redo { loopex(@_, "redo") }
1495 sub pp_goto { loopex(@_, "goto") }
1496 sub pp_dump { loopex(@_, "dump") }
1497
1498 sub ftst {
1499     my $self = shift;
1500     my($op, $cx, $name) = @_;
1501     if (class($op) eq "UNOP") {
1502         # Genuine `-X' filetests are exempt from the LLAFR, but not
1503         # l?stat(); for the sake of clarity, give'em all parens
1504         return $self->maybe_parens_unop($name, $op->first, $cx);
1505     } elsif (class($op) eq "SVOP") {
1506         return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1507     } else { # I don't think baseop filetests ever survive ck_ftst, but...
1508         return $name;
1509     }
1510 }
1511
1512 sub pp_lstat { ftst(@_, "lstat") }
1513 sub pp_stat { ftst(@_, "stat") }
1514 sub pp_ftrread { ftst(@_, "-R") }
1515 sub pp_ftrwrite { ftst(@_, "-W") }
1516 sub pp_ftrexec { ftst(@_, "-X") }
1517 sub pp_fteread { ftst(@_, "-r") }
1518 sub pp_ftewrite { ftst(@_, "-r") }
1519 sub pp_fteexec { ftst(@_, "-r") }
1520 sub pp_ftis { ftst(@_, "-e") }
1521 sub pp_fteowned { ftst(@_, "-O") }
1522 sub pp_ftrowned { ftst(@_, "-o") }
1523 sub pp_ftzero { ftst(@_, "-z") }
1524 sub pp_ftsize { ftst(@_, "-s") }
1525 sub pp_ftmtime { ftst(@_, "-M") }
1526 sub pp_ftatime { ftst(@_, "-A") }
1527 sub pp_ftctime { ftst(@_, "-C") }
1528 sub pp_ftsock { ftst(@_, "-S") }
1529 sub pp_ftchr { ftst(@_, "-c") }
1530 sub pp_ftblk { ftst(@_, "-b") }
1531 sub pp_ftfile { ftst(@_, "-f") }
1532 sub pp_ftdir { ftst(@_, "-d") }
1533 sub pp_ftpipe { ftst(@_, "-p") }
1534 sub pp_ftlink { ftst(@_, "-l") }
1535 sub pp_ftsuid { ftst(@_, "-u") }
1536 sub pp_ftsgid { ftst(@_, "-g") }
1537 sub pp_ftsvtx { ftst(@_, "-k") }
1538 sub pp_fttty { ftst(@_, "-t") }
1539 sub pp_fttext { ftst(@_, "-T") }
1540 sub pp_ftbinary { ftst(@_, "-B") }
1541
1542 sub SWAP_CHILDREN () { 1 }
1543 sub ASSIGN () { 2 } # has OP= variant
1544
1545 my(%left, %right);
1546
1547 sub assoc_class {
1548     my $op = shift;
1549     my $name = $op->name;
1550     if ($name eq "concat" and $op->first->name eq "concat") {
1551         # avoid spurious `=' -- see comment in pp_concat
1552         return "concat";
1553     }
1554     if ($name eq "null" and class($op) eq "UNOP"
1555         and $op->first->name =~ /^(and|x?or)$/
1556         and null $op->first->sibling)
1557     {
1558         # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1559         # with a null that's used as the common end point of the two
1560         # flows of control. For precedence purposes, ignore it.
1561         # (COND_EXPRs have these too, but we don't bother with
1562         # their associativity).
1563         return assoc_class($op->first);
1564     }
1565     return $name . ($op->flags & OPf_STACKED ? "=" : "");
1566 }
1567
1568 # Left associative operators, like `+', for which
1569 # $a + $b + $c is equivalent to ($a + $b) + $c
1570
1571 BEGIN {
1572     %left = ('multiply' => 19, 'i_multiply' => 19,
1573              'divide' => 19, 'i_divide' => 19,
1574              'modulo' => 19, 'i_modulo' => 19,
1575              'repeat' => 19,
1576              'add' => 18, 'i_add' => 18,
1577              'subtract' => 18, 'i_subtract' => 18,
1578              'concat' => 18,
1579              'left_shift' => 17, 'right_shift' => 17,
1580              'bit_and' => 13,
1581              'bit_or' => 12, 'bit_xor' => 12,
1582              'and' => 3,
1583              'or' => 2, 'xor' => 2,
1584             );
1585 }
1586
1587 sub deparse_binop_left {
1588     my $self = shift;
1589     my($op, $left, $prec) = @_;
1590     if ($left{assoc_class($op)} && $left{assoc_class($left)}
1591         and $left{assoc_class($op)} == $left{assoc_class($left)})
1592     {
1593         return $self->deparse($left, $prec - .00001);
1594     } else {
1595         return $self->deparse($left, $prec);
1596     }
1597 }
1598
1599 # Right associative operators, like `=', for which
1600 # $a = $b = $c is equivalent to $a = ($b = $c)
1601
1602 BEGIN {
1603     %right = ('pow' => 22,
1604               'sassign=' => 7, 'aassign=' => 7,
1605               'multiply=' => 7, 'i_multiply=' => 7,
1606               'divide=' => 7, 'i_divide=' => 7,
1607               'modulo=' => 7, 'i_modulo=' => 7,
1608               'repeat=' => 7,
1609               'add=' => 7, 'i_add=' => 7,
1610               'subtract=' => 7, 'i_subtract=' => 7,
1611               'concat=' => 7,
1612               'left_shift=' => 7, 'right_shift=' => 7,
1613               'bit_and=' => 7,
1614               'bit_or=' => 7, 'bit_xor=' => 7,
1615               'andassign' => 7,
1616               'orassign' => 7,
1617              );
1618 }
1619
1620 sub deparse_binop_right {
1621     my $self = shift;
1622     my($op, $right, $prec) = @_;
1623     if ($right{assoc_class($op)} && $right{assoc_class($right)}
1624         and $right{assoc_class($op)} == $right{assoc_class($right)})
1625     {
1626         return $self->deparse($right, $prec - .00001);
1627     } else {
1628         return $self->deparse($right, $prec);
1629     }
1630 }
1631
1632 sub binop {
1633     my $self = shift;
1634     my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1635     my $left = $op->first;
1636     my $right = $op->last;
1637     my $eq = "";
1638     if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1639         $eq = "=";
1640         $prec = 7;
1641     }
1642     if ($flags & SWAP_CHILDREN) {
1643         ($left, $right) = ($right, $left);
1644     }
1645     $left = $self->deparse_binop_left($op, $left, $prec);
1646     $right = $self->deparse_binop_right($op, $right, $prec);
1647     return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1648 }
1649
1650 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1651 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1652 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18,  ASSIGN) }
1653 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1654 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1655 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1656 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1657 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1658 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1659 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1660 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1661
1662 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1663 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1664 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1665 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1666 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1667
1668 sub pp_eq { binop(@_, "==", 14) }
1669 sub pp_ne { binop(@_, "!=", 14) }
1670 sub pp_lt { binop(@_, "<", 15) }
1671 sub pp_gt { binop(@_, ">", 15) }
1672 sub pp_ge { binop(@_, ">=", 15) }
1673 sub pp_le { binop(@_, "<=", 15) }
1674 sub pp_ncmp { binop(@_, "<=>", 14) }
1675 sub pp_i_eq { binop(@_, "==", 14) }
1676 sub pp_i_ne { binop(@_, "!=", 14) }
1677 sub pp_i_lt { binop(@_, "<", 15) }
1678 sub pp_i_gt { binop(@_, ">", 15) }
1679 sub pp_i_ge { binop(@_, ">=", 15) }
1680 sub pp_i_le { binop(@_, "<=", 15) }
1681 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1682
1683 sub pp_seq { binop(@_, "eq", 14) }
1684 sub pp_sne { binop(@_, "ne", 14) }
1685 sub pp_slt { binop(@_, "lt", 15) }
1686 sub pp_sgt { binop(@_, "gt", 15) }
1687 sub pp_sge { binop(@_, "ge", 15) }
1688 sub pp_sle { binop(@_, "le", 15) }
1689 sub pp_scmp { binop(@_, "cmp", 14) }
1690
1691 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1692 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1693
1694 # `.' is special because concats-of-concats are optimized to save copying
1695 # by making all but the first concat stacked. The effect is as if the
1696 # programmer had written `($a . $b) .= $c', except legal.
1697 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1698 sub real_concat {
1699     my $self = shift;
1700     my($op, $cx) = @_;
1701     my $left = $op->first;
1702     my $right = $op->last;
1703     my $eq = "";
1704     my $prec = 18;
1705     if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1706         $eq = "=";
1707         $prec = 7;
1708     }
1709     $left = $self->deparse_binop_left($op, $left, $prec);
1710     $right = $self->deparse_binop_right($op, $right, $prec);
1711     return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1712 }
1713
1714 # `x' is weird when the left arg is a list
1715 sub pp_repeat {
1716     my $self = shift;
1717     my($op, $cx) = @_;
1718     my $left = $op->first;
1719     my $right = $op->last;
1720     my $eq = "";
1721     my $prec = 19;
1722     if ($op->flags & OPf_STACKED) {
1723         $eq = "=";
1724         $prec = 7;
1725     }
1726     if (null($right)) { # list repeat; count is inside left-side ex-list
1727         my $kid = $left->first->sibling; # skip pushmark
1728         my @exprs;
1729         for (; !null($kid->sibling); $kid = $kid->sibling) {
1730             push @exprs, $self->deparse($kid, 6);
1731         }
1732         $right = $kid;
1733         $left = "(" . join(", ", @exprs). ")";
1734     } else {
1735         $left = $self->deparse_binop_left($op, $left, $prec);
1736     }
1737     $right = $self->deparse_binop_right($op, $right, $prec);
1738     return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1739 }
1740
1741 sub range {
1742     my $self = shift;
1743     my ($op, $cx, $type) = @_;
1744     my $left = $op->first;
1745     my $right = $left->sibling;
1746     $left = $self->deparse($left, 9);
1747     $right = $self->deparse($right, 9);
1748     return $self->maybe_parens("$left $type $right", $cx, 9);
1749 }
1750
1751 sub pp_flop {
1752     my $self = shift;
1753     my($op, $cx) = @_;
1754     my $flip = $op->first;
1755     my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1756     return $self->range($flip->first, $cx, $type);
1757 }
1758
1759 # one-line while/until is handled in pp_leave
1760
1761 sub logop {
1762     my $self = shift;
1763     my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1764     my $left = $op->first;
1765     my $right = $op->first->sibling;
1766     if ($cx == 0 and is_scope($right) and $blockname
1767         and $self->{'expand'} < 7)
1768     { # if ($a) {$b}
1769         $left = $self->deparse($left, 1);
1770         $right = $self->deparse($right, 0);
1771         return "$blockname ($left) {\n\t$right\n\b}\cK";
1772     } elsif ($cx == 0 and $blockname and not $self->{'parens'}
1773              and $self->{'expand'} < 7) { # $b if $a
1774         $right = $self->deparse($right, 1);
1775         $left = $self->deparse($left, 1);
1776         return "$right $blockname $left";
1777     } elsif ($cx > $lowprec and $highop) { # $a && $b
1778         $left = $self->deparse_binop_left($op, $left, $highprec);
1779         $right = $self->deparse_binop_right($op, $right, $highprec);
1780         return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1781     } else { # $a and $b
1782         $left = $self->deparse_binop_left($op, $left, $lowprec);
1783         $right = $self->deparse_binop_right($op, $right, $lowprec);
1784         return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1785     }
1786 }
1787
1788 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1789 sub pp_or  { logop(@_, "or",  2, "||", 10, "unless") }
1790
1791 # xor is syntactically a logop, but it's really a binop (contrary to
1792 # old versions of opcode.pl). Syntax is what matters here.
1793 sub pp_xor { logop(@_, "xor", 2, "",   0,  "") }
1794
1795 sub logassignop {
1796     my $self = shift;
1797     my ($op, $cx, $opname) = @_;
1798     my $left = $op->first;
1799     my $right = $op->first->sibling->first; # skip sassign
1800     $left = $self->deparse($left, 7);
1801     $right = $self->deparse($right, 7);
1802     return $self->maybe_parens("$left $opname $right", $cx, 7);
1803 }
1804
1805 sub pp_andassign { logassignop(@_, "&&=") }
1806 sub pp_orassign { logassignop(@_, "||=") }
1807
1808 sub listop {
1809     my $self = shift;
1810     my($op, $cx, $name) = @_;
1811     my(@exprs);
1812     my $parens = ($cx >= 5) || $self->{'parens'};
1813     my $kid = $op->first->sibling;
1814     return $name if null $kid;
1815     my $first = $self->deparse($kid, 6);
1816     $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1817     push @exprs, $first;
1818     $kid = $kid->sibling;
1819     for (; !null($kid); $kid = $kid->sibling) {
1820         push @exprs, $self->deparse($kid, 6);
1821     }
1822     if ($parens) {
1823         return "$name(" . join(", ", @exprs) . ")";
1824     } else {
1825         return "$name " . join(", ", @exprs);
1826     }
1827 }
1828
1829 sub pp_bless { listop(@_, "bless") }
1830 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
1831 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1832 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1833 sub pp_index { maybe_targmy(@_, \&listop, "index") }
1834 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
1835 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
1836 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1837 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
1838 sub pp_unpack { listop(@_, "unpack") }
1839 sub pp_pack { listop(@_, "pack") }
1840 sub pp_join { maybe_targmy(@_, \&listop, "join") }
1841 sub pp_splice { listop(@_, "splice") }
1842 sub pp_push { maybe_targmy(@_, \&listop, "push") }
1843 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
1844 sub pp_reverse { listop(@_, "reverse") }
1845 sub pp_warn { listop(@_, "warn") }
1846 sub pp_die { listop(@_, "die") }
1847 # Actually, return is exempt from the LLAFR (see examples in this very
1848 # module!), but for consistency's sake, ignore that fact
1849 sub pp_return { listop(@_, "return") }
1850 sub pp_open { listop(@_, "open") }
1851 sub pp_pipe_op { listop(@_, "pipe") }
1852 sub pp_tie { listop(@_, "tie") }
1853 sub pp_binmode { listop(@_, "binmode") }
1854 sub pp_dbmopen { listop(@_, "dbmopen") }
1855 sub pp_sselect { listop(@_, "select") }
1856 sub pp_select { listop(@_, "select") }
1857 sub pp_read { listop(@_, "read") }
1858 sub pp_sysopen { listop(@_, "sysopen") }
1859 sub pp_sysseek { listop(@_, "sysseek") }
1860 sub pp_sysread { listop(@_, "sysread") }
1861 sub pp_syswrite { listop(@_, "syswrite") }
1862 sub pp_send { listop(@_, "send") }
1863 sub pp_recv { listop(@_, "recv") }
1864 sub pp_seek { listop(@_, "seek") }
1865 sub pp_fcntl { listop(@_, "fcntl") }
1866 sub pp_ioctl { listop(@_, "ioctl") }
1867 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
1868 sub pp_socket { listop(@_, "socket") }
1869 sub pp_sockpair { listop(@_, "sockpair") }
1870 sub pp_bind { listop(@_, "bind") }
1871 sub pp_connect { listop(@_, "connect") }
1872 sub pp_listen { listop(@_, "listen") }
1873 sub pp_accept { listop(@_, "accept") }
1874 sub pp_shutdown { listop(@_, "shutdown") }
1875 sub pp_gsockopt { listop(@_, "getsockopt") }
1876 sub pp_ssockopt { listop(@_, "setsockopt") }
1877 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
1878 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
1879 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
1880 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
1881 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
1882 sub pp_link { maybe_targmy(@_, \&listop, "link") }
1883 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
1884 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
1885 sub pp_open_dir { listop(@_, "opendir") }
1886 sub pp_seekdir { listop(@_, "seekdir") }
1887 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
1888 sub pp_system { maybe_targmy(@_, \&listop, "system") }
1889 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
1890 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
1891 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
1892 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
1893 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
1894 sub pp_shmget { listop(@_, "shmget") }
1895 sub pp_shmctl { listop(@_, "shmctl") }
1896 sub pp_shmread { listop(@_, "shmread") }
1897 sub pp_shmwrite { listop(@_, "shmwrite") }
1898 sub pp_msgget { listop(@_, "msgget") }
1899 sub pp_msgctl { listop(@_, "msgctl") }
1900 sub pp_msgsnd { listop(@_, "msgsnd") }
1901 sub pp_msgrcv { listop(@_, "msgrcv") }
1902 sub pp_semget { listop(@_, "semget") }
1903 sub pp_semctl { listop(@_, "semctl") }
1904 sub pp_semop { listop(@_, "semop") }
1905 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1906 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1907 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1908 sub pp_gsbyname { listop(@_, "getservbyname") }
1909 sub pp_gsbyport { listop(@_, "getservbyport") }
1910 sub pp_syscall { listop(@_, "syscall") }
1911
1912 sub pp_glob {
1913     my $self = shift;
1914     my($op, $cx) = @_;
1915     my $text = $self->dq($op->first->sibling);  # skip pushmark
1916     if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1917         or $text =~ /[<>]/) {
1918         return 'glob(' . single_delim('qq', '"', $text) . ')';
1919     } else {
1920         return '<' . $text . '>';
1921     }
1922 }
1923
1924 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1925 # be a filehandle. This could probably be better fixed in the core
1926 # by moving the GV lookup into ck_truc.
1927
1928 sub pp_truncate {
1929     my $self = shift;
1930     my($op, $cx) = @_;
1931     my(@exprs);
1932     my $parens = ($cx >= 5) || $self->{'parens'};
1933     my $kid = $op->first->sibling;
1934     my $fh;
1935     if ($op->flags & OPf_SPECIAL) {
1936         # $kid is an OP_CONST
1937         $fh = $self->const_sv($kid)->PV;
1938     } else {
1939         $fh = $self->deparse($kid, 6);
1940         $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1941     }
1942     my $len = $self->deparse($kid->sibling, 6);
1943     if ($parens) {
1944         return "truncate($fh, $len)";
1945     } else {
1946         return "truncate $fh, $len";
1947     }
1948 }
1949
1950 sub indirop {
1951     my $self = shift;
1952     my($op, $cx, $name) = @_;
1953     my($expr, @exprs);
1954     my $kid = $op->first->sibling;
1955     my $indir = "";
1956     if ($op->flags & OPf_STACKED) {
1957         $indir = $kid;
1958         $indir = $indir->first; # skip rv2gv
1959         if (is_scope($indir)) {
1960             $indir = "{" . $self->deparse($indir, 0) . "}";
1961         } else {
1962             $indir = $self->deparse($indir, 24);
1963         }
1964         $indir = $indir . " ";
1965         $kid = $kid->sibling;
1966     }
1967     for (; !null($kid); $kid = $kid->sibling) {
1968         $expr = $self->deparse($kid, 6);
1969         push @exprs, $expr;
1970     }
1971     return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
1972                                     $cx, 5);
1973 }
1974
1975 sub pp_prtf { indirop(@_, "printf") }
1976 sub pp_print { indirop(@_, "print") }
1977 sub pp_sort { indirop(@_, "sort") }
1978
1979 sub mapop {
1980     my $self = shift;
1981     my($op, $cx, $name) = @_;
1982     my($expr, @exprs);
1983     my $kid = $op->first; # this is the (map|grep)start
1984     $kid = $kid->first->sibling; # skip a pushmark
1985     my $code = $kid->first; # skip a null
1986     if (is_scope $code) {
1987         $code = "{" . $self->deparse($code, 0) . "} ";
1988     } else {
1989         $code = $self->deparse($code, 24) . ", ";
1990     }
1991     $kid = $kid->sibling;
1992     for (; !null($kid); $kid = $kid->sibling) {
1993         $expr = $self->deparse($kid, 6);
1994         push @exprs, $expr if $expr;
1995     }
1996     return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1997 }
1998
1999 sub pp_mapwhile { mapop(@_, "map") }
2000 sub pp_grepwhile { mapop(@_, "grep") }
2001
2002 sub pp_list {
2003     my $self = shift;
2004     my($op, $cx) = @_;
2005     my($expr, @exprs);
2006     my $kid = $op->first->sibling; # skip pushmark
2007     my $lop;
2008     my $local = "either"; # could be local(...) or my(...)
2009     for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2010         # This assumes that no other private flags equal 128, and that
2011         # OPs that store things other than flags in their op_private,
2012         # like OP_AELEMFAST, won't be immediate children of a list.
2013         unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
2014         {
2015             $local = ""; # or not
2016             last;
2017         }
2018         if ($lop->name =~ /^pad[ash]v$/) { # my()
2019             ($local = "", last) if $local eq "local";
2020             $local = "my";
2021         } elsif ($lop->name ne "undef") { # local()
2022             ($local = "", last) if $local eq "my";
2023             $local = "local";
2024         }
2025     }
2026     $local = "" if $local eq "either"; # no point if it's all undefs
2027     return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2028     for (; !null($kid); $kid = $kid->sibling) {
2029         if ($local) {
2030             if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2031                 $lop = $kid->first;
2032             } else {
2033                 $lop = $kid;
2034             }
2035             $self->{'avoid_local'}{$$lop}++;
2036             $expr = $self->deparse($kid, 6);
2037             delete $self->{'avoid_local'}{$$lop};
2038         } else {
2039             $expr = $self->deparse($kid, 6);
2040         }
2041         push @exprs, $expr;
2042     }
2043     if ($local) {
2044         return "$local(" . join(", ", @exprs) . ")";
2045     } else {
2046         return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2047     }
2048 }
2049
2050 sub is_ifelse_cont {
2051     my $op = shift;
2052     return ($op->name eq "null" and class($op) eq "UNOP"
2053             and $op->first->name =~ /^(and|cond_expr)$/
2054             and is_scope($op->first->first->sibling));
2055 }
2056
2057 sub pp_cond_expr {
2058     my $self = shift;
2059     my($op, $cx) = @_;
2060     my $cond = $op->first;
2061     my $true = $cond->sibling;
2062     my $false = $true->sibling;
2063     my $cuddle = $self->{'cuddle'};
2064     unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
2065             (is_scope($false) || is_ifelse_cont($false))
2066             and $self->{'expand'} < 7) {
2067         $cond = $self->deparse($cond, 8);
2068         $true = $self->deparse($true, 8);
2069         $false = $self->deparse($false, 8);
2070         return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2071     }
2072
2073     $cond = $self->deparse($cond, 1);
2074     $true = $self->deparse($true, 0);
2075     my $head = "if ($cond) {\n\t$true\n\b}";
2076     my @elsifs;
2077     while (!null($false) and is_ifelse_cont($false)) {
2078         my $newop = $false->first;
2079         my $newcond = $newop->first;
2080         my $newtrue = $newcond->sibling;
2081         $false = $newtrue->sibling; # last in chain is OP_AND => no else
2082         $newcond = $self->deparse($newcond, 1);
2083         $newtrue = $self->deparse($newtrue, 0);
2084         push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2085     }
2086     if (!null($false)) {
2087         $false = $cuddle . "else {\n\t" .
2088           $self->deparse($false, 0) . "\n\b}\cK";
2089     } else {
2090         $false = "\cK";
2091     }
2092     return $head . join($cuddle, "", @elsifs) . $false;
2093 }
2094
2095 sub loop_common {
2096     my $self = shift;
2097     my($op, $cx, $init) = @_;
2098     my $enter = $op->first;
2099     my $kid = $enter->sibling;
2100     local(@$self{qw'curstash warnings hints'})
2101                 = @$self{qw'curstash warnings hints'};
2102     my $head = "";
2103     my $bare = 0;
2104     my $body;
2105     my $cond = undef;
2106     my $out_seq = $self->{'curcop'}->cop_seq;;
2107     if ($kid->name eq "lineseq") { # bare or infinite loop
2108         if (is_state $kid->last) { # infinite
2109             $head = "for (;;) "; # shorter than while (1)
2110             $cond = "";
2111         } else {
2112             $bare = 1;
2113         }
2114         $body = $kid;
2115     } elsif ($enter->name eq "enteriter") { # foreach
2116         my $ary = $enter->first->sibling; # first was pushmark
2117         my $var = $ary->sibling;
2118         if ($enter->flags & OPf_STACKED
2119             and not null $ary->first->sibling->sibling)
2120         {
2121             $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2122               $self->deparse($ary->first->sibling->sibling, 9);
2123         } else {
2124             $ary = $self->deparse($ary, 1);
2125         }
2126         if (null $var) {
2127             if ($enter->flags & OPf_SPECIAL) { # thread special var
2128                 $var = $self->pp_threadsv($enter, 1);
2129             } else { # regular my() variable
2130                 $var = $self->pp_padsv($enter, 1);
2131                 if ($self->padname_sv($enter->targ)->IVX ==
2132                     $kid->first->first->sibling->last->cop_seq)
2133                 {
2134                     # If the scope of this variable closes at the last
2135                     # statement of the loop, it must have been
2136                     # declared here.
2137                     $var = "my " . $var;
2138                 }
2139             }
2140         } elsif ($var->name eq "rv2gv") {
2141             $var = $self->pp_rv2sv($var, 1);
2142         } elsif ($var->name eq "gv") {
2143             $var = "\$" . $self->deparse($var, 1);
2144         }
2145         $head = "foreach $var ($ary) ";
2146         $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2147     } elsif ($kid->name eq "null") { # while/until
2148         $kid = $kid->first;
2149         my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2150         $cond = $self->deparse($kid->first, 1);
2151         $head = "$name ($cond) ";
2152         $body = $kid->first->sibling;
2153     } elsif ($kid->name eq "stub") { # bare and empty
2154         return "{;}"; # {} could be a hashref
2155     }
2156     # If there isn't a continue block, then the next pointer for the loop
2157     # will point to the unstack, which is kid's penultimate child, except
2158     # in a bare loop, when it will point to the leaveloop. When neither of
2159     # these conditions hold, then the third-to-last child in the continue
2160     # block (or the last in a bare loop).
2161     my $cont_start = $enter->nextop;
2162     my $cont;
2163     if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) {
2164         if ($bare) {
2165             $cont = $body->last;
2166         } else {
2167             $cont = $body->first;
2168             while (!null($cont->sibling->sibling->sibling)) {
2169                 $cont = $cont->sibling;
2170             }
2171         }
2172         my $state = $body->first;
2173         my $cuddle = $self->{'cuddle'};
2174         my @states;
2175         for (; $$state != $$cont; $state = $state->sibling) {
2176             push @states, $state;
2177         }
2178         $body = $self->lineseq(@states);
2179         if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2180             $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2181             $cont = "\cK";
2182         } else {
2183             $cont = $cuddle . "continue {\n\t" .
2184               $self->deparse($cont, 0) . "\n\b}\cK";
2185         }
2186     } else {
2187         return "" if !defined $body;
2188         $cont = "\cK";
2189         $body = $self->deparse($body, 0);
2190     }
2191     $body .= "\n";
2192     # If we have say C<{my $x=2; sub x{$x}}>, the sub must go inside
2193     # the loop. So we insert any subs which are due here.
2194     $body .= join"", $self->seq_subs($out_seq);
2195
2196     return $head . "{\n\t" . $body . "\b}" . $cont;
2197 }
2198
2199 sub pp_leaveloop { loop_common(@_, "") }
2200
2201 sub for_loop {
2202     my $self = shift;
2203     my($op, $cx) = @_;
2204     my $init = $self->deparse($op, 1);
2205     return $self->loop_common($op->sibling, $cx, $init);
2206 }
2207
2208 sub pp_leavetry {
2209     my $self = shift;
2210     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2211 }
2212
2213 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2214 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2215
2216 sub pp_null {
2217     my $self = shift;
2218     my($op, $cx) = @_;
2219     if (class($op) eq "OP") {
2220         # old value is lost
2221         return $self->{'ex_const'} if $op->targ == OP_CONST;
2222     } elsif ($op->first->name eq "pushmark") {
2223         return $self->pp_list($op, $cx);
2224     } elsif ($op->first->name eq "enter") {
2225         return $self->pp_leave($op, $cx);
2226     } elsif ($op->targ == OP_STRINGIFY) {
2227         return $self->dquote($op, $cx);
2228     } elsif (!null($op->first->sibling) and
2229              $op->first->sibling->name eq "readline" and
2230              $op->first->sibling->flags & OPf_STACKED) {
2231         return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2232                                    . $self->deparse($op->first->sibling, 7),
2233                                    $cx, 7);
2234     } elsif (!null($op->first->sibling) and
2235              $op->first->sibling->name eq "trans" and
2236              $op->first->sibling->flags & OPf_STACKED) {
2237         return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2238                                    . $self->deparse($op->first->sibling, 20),
2239                                    $cx, 20);
2240     } else {
2241         return $self->deparse($op->first, $cx);
2242     }
2243 }
2244
2245 sub padname {
2246     my $self = shift;
2247     my $targ = shift;
2248     return $self->padname_sv($targ)->PVX;
2249 }
2250
2251 sub padany {
2252     my $self = shift;
2253     my $op = shift;
2254     return substr($self->padname($op->targ), 1); # skip $/@/%
2255 }
2256
2257 sub pp_padsv {
2258     my $self = shift;
2259     my($op, $cx) = @_;
2260     return $self->maybe_my($op, $cx, $self->padname($op->targ));
2261 }
2262
2263 sub pp_padav { pp_padsv(@_) }
2264 sub pp_padhv { pp_padsv(@_) }
2265
2266 my @threadsv_names;
2267
2268 BEGIN {
2269     @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2270                        "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2271                        "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2272                        "!", "@");
2273 }
2274
2275 sub pp_threadsv {
2276     my $self = shift;
2277     my($op, $cx) = @_;
2278     return $self->maybe_local($op, $cx, "\$" .  $threadsv_names[$op->targ]);
2279 }
2280
2281 sub gv_or_padgv {
2282     my $self = shift;
2283     my $op = shift;
2284     if (class($op) eq "PADOP") {
2285         return $self->padval($op->padix);
2286     } else { # class($op) eq "SVOP"
2287         return $op->gv;
2288     }
2289 }
2290
2291 sub pp_gvsv {
2292     my $self = shift;
2293     my($op, $cx) = @_;
2294     my $gv = $self->gv_or_padgv($op);
2295     return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv));
2296 }
2297
2298 sub pp_gv {
2299     my $self = shift;
2300     my($op, $cx) = @_;
2301     my $gv = $self->gv_or_padgv($op);
2302     return $self->gv_name($gv);
2303 }
2304
2305 sub pp_aelemfast {
2306     my $self = shift;
2307     my($op, $cx) = @_;
2308     my $gv = $self->gv_or_padgv($op);
2309     return "\$" . $self->gv_name($gv) . "[" .
2310                   ($op->private + $self->{'arybase'}) . "]";
2311 }
2312
2313 sub rv2x {
2314     my $self = shift;
2315     my($op, $cx, $type) = @_;
2316     my $kid = $op->first;
2317     my $str = $self->deparse($kid, 0);
2318     return $type . (is_scalar($kid) ? $str : "{$str}");
2319 }
2320
2321 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2322 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2323 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2324
2325 # skip rv2av
2326 sub pp_av2arylen {
2327     my $self = shift;
2328     my($op, $cx) = @_;
2329     if ($op->first->name eq "padav") {
2330         return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2331     } else {
2332         return $self->maybe_local($op, $cx,
2333                                   $self->rv2x($op->first, $cx, '$#'));
2334     }
2335 }
2336
2337 # skip down to the old, ex-rv2cv
2338 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
2339
2340 sub pp_rv2av {
2341     my $self = shift;
2342     my($op, $cx) = @_;
2343     my $kid = $op->first;
2344     if ($kid->name eq "const") { # constant list
2345         my $av = $self->const_sv($kid);
2346         return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2347     } else {
2348         return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2349     }
2350  }
2351
2352 sub is_subscriptable {
2353     my $op = shift;
2354     if ($op->name =~ /^[ahg]elem/) {
2355         return 1;
2356     } elsif ($op->name eq "entersub") {
2357         my $kid = $op->first;
2358         return 0 unless null $kid->sibling;
2359         $kid = $kid->first;
2360         $kid = $kid->sibling until null $kid->sibling;
2361         return 0 if is_scope($kid);
2362         $kid = $kid->first;
2363         return 0 if $kid->name eq "gv";
2364         return 0 if is_scalar($kid);
2365         return is_subscriptable($kid);
2366     } else {
2367         return 0;
2368     }
2369 }
2370
2371 sub elem {
2372     my $self = shift;
2373     my ($op, $cx, $left, $right, $padname) = @_;
2374     my($array, $idx) = ($op->first, $op->first->sibling);
2375     unless ($array->name eq $padname) { # Maybe this has been fixed
2376         $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2377     }
2378     if ($array->name eq $padname) {
2379         $array = $self->padany($array);
2380     } elsif (is_scope($array)) { # ${expr}[0]
2381         $array = "{" . $self->deparse($array, 0) . "}";
2382     } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2383         $array = $self->deparse($array, 24);
2384     } else {
2385         # $x[20][3]{hi} or expr->[20]
2386         my $arrow = is_subscriptable($array) ? "" : "->";
2387         return $self->deparse($array, 24) . $arrow .
2388             $left . $self->deparse($idx, 1) . $right;
2389     }
2390     $idx = $self->deparse($idx, 1);
2391
2392     # Outer parens in an array index will confuse perl
2393     # if we're interpolating in a regular expression, i.e.
2394     # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2395     #
2396     # If $self->{parens}, then an initial '(' will
2397     # definitely be paired with a final ')'. If
2398     # !$self->{parens}, the misleading parens won't
2399     # have been added in the first place.
2400     #
2401     # [You might think that we could get "(...)...(...)"
2402     # where the initial and final parens do not match
2403     # each other. But we can't, because the above would
2404     # only happen if there's an infix binop between the
2405     # two pairs of parens, and *that* means that the whole
2406     # expression would be parenthesized as well.]
2407     #
2408     $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2409
2410     return "\$" . $array . $left . $idx . $right;
2411 }
2412
2413 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2414 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2415
2416 sub pp_gelem {
2417     my $self = shift;
2418     my($op, $cx) = @_;
2419     my($glob, $part) = ($op->first, $op->last);
2420     $glob = $glob->first; # skip rv2gv
2421     $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2422     my $scope = is_scope($glob);
2423     $glob = $self->deparse($glob, 0);
2424     $part = $self->deparse($part, 1);
2425     return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2426 }
2427
2428 sub slice {
2429     my $self = shift;
2430     my ($op, $cx, $left, $right, $regname, $padname) = @_;
2431     my $last;
2432     my(@elems, $kid, $array, $list);
2433     if (class($op) eq "LISTOP") {
2434         $last = $op->last;
2435     } else { # ex-hslice inside delete()
2436         for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2437         $last = $kid;
2438     }
2439     $array = $last;
2440     $array = $array->first
2441         if $array->name eq $regname or $array->name eq "null";
2442     if (is_scope($array)) {
2443         $array = "{" . $self->deparse($array, 0) . "}";
2444     } elsif ($array->name eq $padname) {
2445         $array = $self->padany($array);
2446     } else {
2447         $array = $self->deparse($array, 24);
2448     }
2449     $kid = $op->first->sibling; # skip pushmark
2450     if ($kid->name eq "list") {
2451         $kid = $kid->first->sibling; # skip list, pushmark
2452         for (; !null $kid; $kid = $kid->sibling) {
2453             push @elems, $self->deparse($kid, 6);
2454         }
2455         $list = join(", ", @elems);
2456     } else {
2457         $list = $self->deparse($kid, 1);
2458     }
2459     return "\@" . $array . $left . $list . $right;
2460 }
2461
2462 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2463 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2464
2465 sub pp_lslice {
2466     my $self = shift;
2467     my($op, $cx) = @_;
2468     my $idx = $op->first;
2469     my $list = $op->last;
2470     my(@elems, $kid);
2471     $list = $self->deparse($list, 1);
2472     $idx = $self->deparse($idx, 1);
2473     return "($list)" . "[$idx]";
2474 }
2475
2476 sub want_scalar {
2477     my $op = shift;
2478     return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2479 }
2480
2481 sub want_list {
2482     my $op = shift;
2483     return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2484 }
2485
2486 sub method {
2487     my $self = shift;
2488     my($op, $cx) = @_;
2489     my $kid = $op->first->sibling; # skip pushmark
2490     my($meth, $obj, @exprs);
2491     if ($kid->name eq "list" and want_list $kid) {
2492         # When an indirect object isn't a bareword but the args are in
2493         # parens, the parens aren't part of the method syntax (the LLAFR
2494         # doesn't apply), but they make a list with OPf_PARENS set that
2495         # doesn't get flattened by the append_elem that adds the method,
2496         # making a (object, arg1, arg2, ...) list where the object
2497         # usually is. This can be distinguished from
2498         # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2499         # object) because in the later the list is in scalar context
2500         # as the left side of -> always is, while in the former
2501         # the list is in list context as method arguments always are.
2502         # (Good thing there aren't method prototypes!)
2503         $meth = $kid->sibling;
2504         $kid = $kid->first->sibling; # skip pushmark
2505         $obj = $kid;
2506         $kid = $kid->sibling;
2507         for (; not null $kid; $kid = $kid->sibling) {
2508             push @exprs, $self->deparse($kid, 6);
2509         }
2510     } else {
2511         $obj = $kid;
2512         $kid = $kid->sibling;
2513         for (; not null $kid->sibling; $kid = $kid->sibling) {
2514             push @exprs, $self->deparse($kid, 6);
2515         }
2516         $meth = $kid;
2517     }
2518     $obj = $self->deparse($obj, 24);
2519     if ($meth->name eq "method_named") {
2520         $meth = $self->const_sv($meth)->PV;
2521     } else {
2522         $meth = $meth->first;
2523         if ($meth->name eq "const") {
2524             # As of 5.005_58, this case is probably obsoleted by the
2525             # method_named case above
2526             $meth = $self->const_sv($meth)->PV; # needs to be bare
2527         } else {
2528             $meth = $self->deparse($meth, 1);
2529         }
2530     }
2531     my $args = join(", ", @exprs);
2532     $kid = $obj . "->" . $meth;
2533     if ($args) {
2534         return $kid . "(" . $args . ")"; # parens mandatory
2535     } else {
2536         return $kid;
2537     }
2538 }
2539
2540 # returns "&" if the prototype doesn't match the args,
2541 # or ("", $args_after_prototype_demunging) if it does.
2542 sub check_proto {
2543     my $self = shift;
2544     my($proto, @args) = @_;
2545     my($arg, $real);
2546     my $doneok = 0;
2547     my @reals;
2548     # An unbackslashed @ or % gobbles up the rest of the args
2549     $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2550     while ($proto) {
2551         $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2552         my $chr = $1;
2553         if ($chr eq "") {
2554             return "&" if @args;
2555         } elsif ($chr eq ";") {
2556             $doneok = 1;
2557         } elsif ($chr eq "@" or $chr eq "%") {
2558             push @reals, map($self->deparse($_, 6), @args);
2559             @args = ();
2560         } else {
2561             $arg = shift @args;
2562             last unless $arg;
2563             if ($chr eq "\$") {
2564                 if (want_scalar $arg) {
2565                     push @reals, $self->deparse($arg, 6);
2566                 } else {
2567                     return "&";
2568                 }
2569             } elsif ($chr eq "&") {
2570                 if ($arg->name =~ /^(s?refgen|undef)$/) {
2571                     push @reals, $self->deparse($arg, 6);
2572                 } else {
2573                     return "&";
2574                 }
2575             } elsif ($chr eq "*") {
2576                 if ($arg->name =~ /^s?refgen$/
2577                     and $arg->first->first->name eq "rv2gv")
2578                   {
2579                       $real = $arg->first->first; # skip refgen, null
2580                       if ($real->first->name eq "gv") {
2581                           push @reals, $self->deparse($real, 6);
2582                       } else {
2583                           push @reals, $self->deparse($real->first, 6);
2584                       }
2585                   } else {
2586                       return "&";
2587                   }
2588             } elsif (substr($chr, 0, 1) eq "\\") {
2589                 $chr = substr($chr, 1);
2590                 if ($arg->name =~ /^s?refgen$/ and
2591                     !null($real = $arg->first) and
2592                     ($chr eq "\$" && is_scalar($real->first)
2593                      or ($chr eq "\@"
2594                          && $real->first->sibling->name
2595                          =~ /^(rv2|pad)av$/)
2596                      or ($chr eq "%"
2597                          && $real->first->sibling->name
2598                          =~ /^(rv2|pad)hv$/)
2599                      #or ($chr eq "&" # This doesn't work
2600                      #   && $real->first->name eq "rv2cv")
2601                      or ($chr eq "*"
2602                          && $real->first->name eq "rv2gv")))
2603                   {
2604                       push @reals, $self->deparse($real, 6);
2605                   } else {
2606                       return "&";
2607                   }
2608             }
2609        }
2610     }
2611     return "&" if $proto and !$doneok; # too few args and no `;'
2612     return "&" if @args;               # too many args
2613     return ("", join ", ", @reals);
2614 }
2615
2616 sub pp_entersub {
2617     my $self = shift;
2618     my($op, $cx) = @_;
2619     return $self->method($op, $cx) unless null $op->first->sibling;
2620     my $prefix = "";
2621     my $amper = "";
2622     my($kid, @exprs);
2623     if ($op->flags & OPf_SPECIAL) {
2624         $prefix = "do ";
2625     } elsif ($op->private & OPpENTERSUB_AMPER) {
2626         $amper = "&";
2627     }
2628     $kid = $op->first;
2629     $kid = $kid->first->sibling; # skip ex-list, pushmark
2630     for (; not null $kid->sibling; $kid = $kid->sibling) {
2631         push @exprs, $kid;
2632     }
2633     my $simple = 0;
2634     my $proto = undef;
2635     if (is_scope($kid)) {
2636         $amper = "&";
2637         $kid = "{" . $self->deparse($kid, 0) . "}";
2638     } elsif ($kid->first->name eq "gv") {
2639         my $gv = $self->gv_or_padgv($kid->first);
2640         if (class($gv->CV) ne "SPECIAL") {
2641             $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2642         }
2643         $simple = 1; # only calls of named functions can be prototyped
2644         $kid = $self->deparse($kid, 24);
2645     } elsif (is_scalar $kid->first) {
2646         $amper = "&";
2647         $kid = $self->deparse($kid, 24);
2648     } else {
2649         $prefix = "";
2650         my $arrow = is_subscriptable($kid->first) ? "" : "->";
2651         $kid = $self->deparse($kid, 24) . $arrow;
2652     }
2653
2654     # Doesn't matter how many prototypes there are, if
2655     # they haven't happened yet!
2656     my $declared = exists $self->{'subs_declared'}{$kid};
2657
2658     my $args;
2659     if ($declared and defined $proto and not $amper) {
2660         ($amper, $args) = $self->check_proto($proto, @exprs);
2661         if ($amper eq "&") {
2662             $args = join(", ", map($self->deparse($_, 6), @exprs));
2663         }
2664     } else {
2665         $args = join(", ", map($self->deparse($_, 6), @exprs));
2666     }
2667     if ($prefix or $amper) {
2668         if ($op->flags & OPf_STACKED) {
2669             return $prefix . $amper . $kid . "(" . $args . ")";
2670         } else {
2671             return $prefix . $amper. $kid;
2672         }
2673     } else {
2674         # glob() invocations can be translated into calls of
2675         # CORE::GLOBAL::glob with an second parameter, a number.
2676         # Reverse this.
2677         if ($kid eq "CORE::GLOBAL::glob") {
2678             $kid = "glob";
2679             $args =~ s/\s*,[^,]+$//;
2680         }
2681
2682         # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
2683         # so it must have been translated from a keyword call. Translate
2684         # it back.
2685         $kid =~ s/^CORE::GLOBAL:://;
2686
2687         if (!$declared) {
2688             return "$kid(" . $args . ")";
2689         } elsif (defined $proto and $proto eq "") {
2690             return $kid;
2691         } elsif (defined $proto and $proto eq "\$") {
2692             return $self->maybe_parens_func($kid, $args, $cx, 16);
2693         } elsif (defined($proto) && $proto or $simple) {
2694             return $self->maybe_parens_func($kid, $args, $cx, 5);
2695         } else {
2696             return "$kid(" . $args . ")";
2697         }
2698     }
2699 }
2700
2701 sub pp_enterwrite { unop(@_, "write") }
2702
2703 # escape things that cause interpolation in double quotes,
2704 # but not character escapes
2705 sub uninterp {
2706     my($str) = @_;
2707     $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2708     return $str;
2709 }
2710
2711 # the same, but treat $|, $), and $ at the end of the string differently
2712 sub re_uninterp {
2713     my($str) = @_;
2714     $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2715     $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2716     return $str;
2717 }
2718
2719 # character escapes, but not delimiters that might need to be escaped
2720 sub escape_str { # ASCII, UTF8
2721     my($str) = @_;
2722     $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
2723     $str =~ s/\a/\\a/g;
2724 #    $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2725     $str =~ s/\t/\\t/g;
2726     $str =~ s/\n/\\n/g;
2727     $str =~ s/\e/\\e/g;
2728     $str =~ s/\f/\\f/g;
2729     $str =~ s/\r/\\r/g;
2730     $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2731     $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2732     return $str;
2733 }
2734
2735 # Don't do this for regexen
2736 sub unback {
2737     my($str) = @_;
2738     $str =~ s/\\/\\\\/g;
2739     return $str;
2740 }
2741
2742 # Remove backslashes which precede literal control characters,
2743 # to avoid creating ambiguity when we escape the latter.
2744 sub re_unback {
2745     my($str) = @_;
2746
2747     # the insane complexity here is due to the behaviour of "\c\"
2748     $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
2749     return $str;
2750 }
2751
2752 sub balanced_delim {
2753     my($str) = @_;
2754     my @str = split //, $str;
2755     my($ar, $open, $close, $fail, $c, $cnt);
2756     for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2757         ($open, $close) = @$ar;
2758         $fail = 0; $cnt = 0;
2759         for $c (@str) {
2760             if ($c eq $open) {
2761                 $cnt++;
2762             } elsif ($c eq $close) {
2763                 $cnt--;
2764                 if ($cnt < 0) {
2765                     # qq()() isn't ")("
2766                     $fail = 1;
2767                     last;
2768                 }
2769             }
2770         }
2771         $fail = 1 if $cnt != 0;
2772         return ($open, "$open$str$close") if not $fail;
2773     }
2774     return ("", $str);
2775 }
2776
2777 sub single_delim {
2778     my($q, $default, $str) = @_;
2779     return "$default$str$default" if $default and index($str, $default) == -1;
2780     my($succeed, $delim);
2781     ($succeed, $str) = balanced_delim($str);
2782     return "$q$str" if $succeed;
2783     for $delim ('/', '"', '#') {
2784         return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2785     }
2786     if ($default) {
2787         $str =~ s/$default/\\$default/g;
2788         return "$default$str$default";
2789     } else {
2790         $str =~ s[/][\\/]g;
2791         return "$q/$str/";
2792     }
2793 }
2794
2795 sub const {
2796     my $sv = shift;
2797     if (class($sv) eq "SPECIAL") {
2798         return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2799     } elsif (class($sv) eq "NULL") {
2800        return 'undef';
2801     } elsif ($sv->FLAGS & SVf_IOK) {
2802         return $sv->int_value;
2803     } elsif ($sv->FLAGS & SVf_NOK) {
2804         return $sv->NV;
2805     } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
2806         return "\\(" . const($sv->RV) . ")"; # constant folded
2807     } else {
2808         my $str = $sv->PV;
2809         if ($str =~ /[^ -~]/) { # ASCII for non-printing
2810             return single_delim("qq", '"', uninterp escape_str unback $str);
2811         } else {
2812             return single_delim("q", "'", unback $str);
2813         }
2814     }
2815 }
2816
2817 sub const_sv {
2818     my $self = shift;
2819     my $op = shift;
2820     my $sv = $op->sv;
2821     # the constant could be in the pad (under useithreads)
2822     $sv = $self->padval($op->targ) unless $$sv;
2823     return $sv;
2824 }
2825
2826 sub pp_const {
2827     my $self = shift;
2828     my($op, $cx) = @_;
2829     if ($op->private & OPpCONST_ARYBASE) {
2830         return '$[';
2831     }
2832 #    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2833 #       return $self->const_sv($op)->PV;
2834 #    }
2835     my $sv = $self->const_sv($op);
2836 #    return const($sv);
2837     my $c = const $sv;
2838     return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
2839 }
2840
2841 sub dq {
2842     my $self = shift;
2843     my $op = shift;
2844     my $type = $op->name;
2845     if ($type eq "const") {
2846         return '$[' if $op->private & OPpCONST_ARYBASE;
2847         return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
2848     } elsif ($type eq "concat") {
2849         my $first = $self->dq($op->first);
2850         my $last  = $self->dq($op->last);
2851         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2852         if ($last =~ /^[A-Z\\\^\[\]_?]/) {
2853             $first =~ s/([\$@])\^$/${1}{^}/;  # "${^}W" etc
2854         }
2855         elsif ($last =~ /^[{\[\w]/) {
2856             $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2857         }
2858         return $first . $last;
2859     } elsif ($type eq "uc") {
2860         return '\U' . $self->dq($op->first->sibling) . '\E';
2861     } elsif ($type eq "lc") {
2862         return '\L' . $self->dq($op->first->sibling) . '\E';
2863     } elsif ($type eq "ucfirst") {
2864         return '\u' . $self->dq($op->first->sibling);
2865     } elsif ($type eq "lcfirst") {
2866         return '\l' . $self->dq($op->first->sibling);
2867     } elsif ($type eq "quotemeta") {
2868         return '\Q' . $self->dq($op->first->sibling) . '\E';
2869     } elsif ($type eq "join") {
2870         return $self->deparse($op->last, 26); # was join($", @ary)
2871     } else {
2872         return $self->deparse($op, 26);
2873     }
2874 }
2875
2876 sub pp_backtick {
2877     my $self = shift;
2878     my($op, $cx) = @_;
2879     # skip pushmark
2880     return single_delim("qx", '`', $self->dq($op->first->sibling));
2881 }
2882
2883 sub dquote {
2884     my $self = shift;
2885     my($op, $cx) = @_;
2886     my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2887     return $self->deparse($kid, $cx) if $self->{'unquote'};
2888     $self->maybe_targmy($kid, $cx,
2889                         sub {single_delim("qq", '"', $self->dq($_[1]))});
2890 }
2891
2892 # OP_STRINGIFY is a listop, but it only ever has one arg
2893 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2894
2895 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2896 # note that tr(from)/to/ is OK, but not tr/from/(to)
2897 sub double_delim {
2898     my($from, $to) = @_;
2899     my($succeed, $delim);
2900     if ($from !~ m[/] and $to !~ m[/]) {
2901         return "/$from/$to/";
2902     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2903         if (($succeed, $to) = balanced_delim($to) and $succeed) {
2904             return "$from$to";
2905         } else {
2906             for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2907                 return "$from$delim$to$delim" if index($to, $delim) == -1;
2908             }
2909             $to =~ s[/][\\/]g;
2910             return "$from/$to/";
2911         }
2912     } else {
2913         for $delim ('/', '"', '#') { # note no '
2914             return "$delim$from$delim$to$delim"
2915                 if index($to . $from, $delim) == -1;
2916         }
2917         $from =~ s[/][\\/]g;
2918         $to =~ s[/][\\/]g;
2919         return "/$from/$to/";
2920     }
2921 }
2922
2923 sub pchr { # ASCII
2924     my($n) = @_;
2925     if ($n == ord '\\') {
2926         return '\\\\';
2927     } elsif ($n >= ord(' ') and $n <= ord('~')) {
2928         return chr($n);
2929     } elsif ($n == ord "\a") {
2930         return '\\a';
2931     } elsif ($n == ord "\b") {
2932         return '\\b';
2933     } elsif ($n == ord "\t") {
2934         return '\\t';
2935     } elsif ($n == ord "\n") {
2936         return '\\n';
2937     } elsif ($n == ord "\e") {
2938         return '\\e';
2939     } elsif ($n == ord "\f") {
2940         return '\\f';
2941     } elsif ($n == ord "\r") {
2942         return '\\r';
2943     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2944         return '\\c' . chr(ord("@") + $n);
2945     } else {
2946 #       return '\x' . sprintf("%02x", $n);
2947         return '\\' . sprintf("%03o", $n);
2948     }
2949 }
2950
2951 sub collapse {
2952     my(@chars) = @_;
2953     my($str, $c, $tr) = ("");
2954     for ($c = 0; $c < @chars; $c++) {
2955         $tr = $chars[$c];
2956         $str .= pchr($tr);
2957         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2958             $chars[$c + 2] == $tr + 2)
2959         {
2960             for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
2961               {}
2962             $str .= "-";
2963             $str .= pchr($chars[$c]);
2964         }
2965     }
2966     return $str;
2967 }
2968
2969 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
2970 # and backslashes.
2971
2972 sub tr_decode_byte {
2973     my($table, $flags) = @_;
2974     my(@table) = unpack("s256", $table);
2975     my($c, $tr, @from, @to, @delfrom, $delhyphen);
2976     if ($table[ord "-"] != -1 and
2977         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2978     {
2979         $tr = $table[ord "-"];
2980         $table[ord "-"] = -1;
2981         if ($tr >= 0) {
2982             @from = ord("-");
2983             @to = $tr;
2984         } else { # -2 ==> delete
2985             $delhyphen = 1;
2986         }
2987     }
2988     for ($c = 0; $c < 256; $c++) {
2989         $tr = $table[$c];
2990         if ($tr >= 0) {
2991             push @from, $c; push @to, $tr;
2992         } elsif ($tr == -2) {
2993             push @delfrom, $c;
2994         }
2995     }
2996     @from = (@from, @delfrom);
2997     if ($flags & OPpTRANS_COMPLEMENT) {
2998         my @newfrom = ();
2999         my %from;
3000         @from{@from} = (1) x @from;
3001         for ($c = 0; $c < 256; $c++) {
3002             push @newfrom, $c unless $from{$c};
3003         }
3004         @from = @newfrom;
3005     }
3006     unless ($flags & OPpTRANS_DELETE || !@to) {
3007         pop @to while $#to and $to[$#to] == $to[$#to -1];
3008     }
3009     my($from, $to);
3010     $from = collapse(@from);
3011     $to = collapse(@to);
3012     $from .= "-" if $delhyphen;
3013     return ($from, $to);
3014 }
3015
3016 sub tr_chr {
3017     my $x = shift;
3018     if ($x == ord "-") {
3019         return "\\-";
3020     } else {
3021         return chr $x;
3022     }
3023 }
3024
3025 # XXX This doesn't yet handle all cases correctly either
3026
3027 sub tr_decode_utf8 {
3028     my($swash_hv, $flags) = @_;
3029     my %swash = $swash_hv->ARRAY;
3030     my $final = undef;
3031     $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3032     my $none = $swash{"NONE"}->IV;
3033     my $extra = $none + 1;
3034     my(@from, @delfrom, @to);
3035     my $line;
3036     foreach $line (split /\n/, $swash{'LIST'}->PV) {
3037         my($min, $max, $result) = split(/\t/, $line);
3038         $min = hex $min;
3039         if (length $max) {
3040             $max = hex $max;
3041         } else {
3042             $max = $min;
3043         }
3044         $result = hex $result;
3045         if ($result == $extra) {
3046             push @delfrom, [$min, $max];
3047         } else {
3048             push @from, [$min, $max];
3049             push @to, [$result, $result + $max - $min];
3050         }
3051     }
3052     for my $i (0 .. $#from) {
3053         if ($from[$i][0] == ord '-') {
3054             unshift @from, splice(@from, $i, 1);
3055             unshift @to, splice(@to, $i, 1);
3056             last;
3057         } elsif ($from[$i][1] == ord '-') {
3058             $from[$i][1]--;
3059             $to[$i][1]--;
3060             unshift @from, ord '-';
3061             unshift @to, ord '-';
3062             last;
3063         }
3064     }
3065     for my $i (0 .. $#delfrom) {
3066         if ($delfrom[$i][0] == ord '-') {
3067             push @delfrom, splice(@delfrom, $i, 1);
3068             last;
3069         } elsif ($delfrom[$i][1] == ord '-') {
3070             $delfrom[$i][1]--;
3071             push @delfrom, ord '-';
3072             last;
3073         }
3074     }
3075     if (defined $final and $to[$#to][1] != $final) {
3076         push @to, [$final, $final];
3077     }
3078     push @from, @delfrom;
3079     if ($flags & OPpTRANS_COMPLEMENT) {
3080         my @newfrom;
3081         my $next = 0;
3082         for my $i (0 .. $#from) {
3083             push @newfrom, [$next, $from[$i][0] - 1];
3084             $next = $from[$i][1] + 1;
3085         }
3086         @from = ();
3087         for my $range (@newfrom) {
3088             if ($range->[0] <= $range->[1]) {
3089                 push @from, $range;
3090             }
3091         }
3092     }
3093     my($from, $to, $diff);
3094     for my $chunk (@from) {
3095         $diff = $chunk->[1] - $chunk->[0];
3096         if ($diff > 1) {
3097             $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3098         } elsif ($diff == 1) {
3099             $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3100         } else {
3101             $from .= tr_chr($chunk->[0]);
3102         }
3103     }
3104     for my $chunk (@to) {
3105         $diff = $chunk->[1] - $chunk->[0];
3106         if ($diff > 1) {
3107             $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3108         } elsif ($diff == 1) {
3109             $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3110         } else {
3111             $to .= tr_chr($chunk->[0]);
3112         }
3113     }
3114     #$final = sprintf("%04x", $final) if defined $final;
3115     #$none = sprintf("%04x", $none) if defined $none;
3116     #$extra = sprintf("%04x", $extra) if defined $extra;
3117     #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3118     #print STDERR $swash{'LIST'}->PV;
3119     return (escape_str($from), escape_str($to));
3120 }
3121
3122 sub pp_trans {
3123     my $self = shift;
3124     my($op, $cx) = @_;
3125     my($from, $to);
3126     if (class($op) eq "PVOP") {
3127         ($from, $to) = tr_decode_byte($op->pv, $op->private);
3128     } else { # class($op) eq "SVOP"
3129         ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3130     }
3131     my $flags = "";
3132     $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3133     $flags .= "d" if $op->private & OPpTRANS_DELETE;
3134     $to = "" if $from eq $to and $flags eq "";
3135     $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3136     return "tr" . double_delim($from, $to) . $flags;
3137 }
3138
3139 # Like dq(), but different
3140 sub re_dq {
3141     my $self = shift;
3142     my $op = shift;
3143     my $type = $op->name;
3144     if ($type eq "const") {
3145         return '$[' if $op->private & OPpCONST_ARYBASE;
3146         return re_uninterp(escape_str(re_unback($self->const_sv($op)->as_string)));
3147     } elsif ($type eq "concat") {
3148         my $first = $self->re_dq($op->first);
3149         my $last  = $self->re_dq($op->last);
3150         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3151         if ($last =~ /^[A-Z\\\^\[\]_?]/) {
3152             $first =~ s/([\$@])\^$/${1}{^}/;
3153         }
3154         elsif ($last =~ /^[{\[\w]/) {
3155             $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
3156         }
3157         return $first . $last;
3158     } elsif ($type eq "uc") {
3159         return '\U' . $self->re_dq($op->first->sibling) . '\E';
3160     } elsif ($type eq "lc") {
3161         return '\L' . $self->re_dq($op->first->sibling) . '\E';
3162     } elsif ($type eq "ucfirst") {
3163         return '\u' . $self->re_dq($op->first->sibling);
3164     } elsif ($type eq "lcfirst") {
3165         return '\l' . $self->re_dq($op->first->sibling);
3166     } elsif ($type eq "quotemeta") {
3167         return '\Q' . $self->re_dq($op->first->sibling) . '\E';
3168     } elsif ($type eq "join") {
3169         return $self->deparse($op->last, 26); # was join($", @ary)
3170     } else {
3171         return $self->deparse($op, 26);
3172     }
3173 }
3174
3175 sub pp_regcomp {
3176     my $self = shift;
3177     my($op, $cx) = @_;
3178     my $kid = $op->first;
3179     $kid = $kid->first if $kid->name eq "regcmaybe";
3180     $kid = $kid->first if $kid->name eq "regcreset";
3181     return $self->re_dq($kid);
3182 }
3183
3184 # osmic acid -- see osmium tetroxide
3185
3186 my %matchwords;
3187 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3188     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3189     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3190
3191 sub matchop {
3192     my $self = shift;
3193     my($op, $cx, $name, $delim) = @_;
3194     my $kid = $op->first;
3195     my ($binop, $var, $re) = ("", "", "");
3196     if ($op->flags & OPf_STACKED) {
3197         $binop = 1;
3198         $var = $self->deparse($kid, 20);
3199         $kid = $kid->sibling;
3200     }
3201     if (null $kid) {
3202         $re = re_uninterp(escape_str(re_unback($op->precomp)));
3203     } else {
3204         $re = $self->deparse($kid, 1);
3205     }
3206     my $flags = "";
3207     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3208     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3209     $flags .= "i" if $op->pmflags & PMf_FOLD;
3210     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3211     $flags .= "o" if $op->pmflags & PMf_KEEP;
3212     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3213     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3214     $flags = $matchwords{$flags} if $matchwords{$flags};
3215     if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3216         $re =~ s/\?/\\?/g;
3217         $re = "?$re?";
3218     } else {
3219         $re = single_delim($name, $delim, $re);
3220     }
3221     $re = $re . $flags;
3222     if ($binop) {
3223         return $self->maybe_parens("$var =~ $re", $cx, 20);
3224     } else {
3225         return $re;
3226     }
3227 }
3228
3229 sub pp_match { matchop(@_, "m", "/") }
3230 sub pp_pushre { matchop(@_, "m", "/") }
3231 sub pp_qr { matchop(@_, "qr", "") }
3232
3233 sub pp_split {
3234     my $self = shift;
3235     my($op, $cx) = @_;
3236     my($kid, @exprs, $ary, $expr);
3237     $kid = $op->first;
3238     if ($ {$kid->pmreplroot}) {
3239         $ary = '@' . $self->gv_name($kid->pmreplroot);
3240     }
3241     for (; !null($kid); $kid = $kid->sibling) {
3242         push @exprs, $self->deparse($kid, 6);
3243     }
3244
3245     # handle special case of split(), and split(" ") that compiles to /\s+/
3246     $kid = $op->first;
3247     if ($kid->flags & OPf_SPECIAL
3248         && $exprs[0] eq '/\\s+/'
3249         && $kid->pmflags & PMf_SKIPWHITE ) {
3250             $exprs[0] = '" "';
3251     }
3252
3253     $expr = "split(" . join(", ", @exprs) . ")";
3254     if ($ary) {
3255         return $self->maybe_parens("$ary = $expr", $cx, 7);
3256     } else {
3257         return $expr;
3258     }
3259 }
3260
3261 # oxime -- any of various compounds obtained chiefly by the action of
3262 # hydroxylamine on aldehydes and ketones and characterized by the
3263 # bivalent grouping C=NOH [Webster's Tenth]
3264
3265 my %substwords;
3266 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3267     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3268     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3269     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3270
3271 sub pp_subst {
3272     my $self = shift;
3273     my($op, $cx) = @_;
3274     my $kid = $op->first;
3275     my($binop, $var, $re, $repl) = ("", "", "", "");
3276     if ($op->flags & OPf_STACKED) {
3277         $binop = 1;
3278         $var = $self->deparse($kid, 20);
3279         $kid = $kid->sibling;
3280     }
3281     my $flags = "";
3282     if (null($op->pmreplroot)) {
3283         $repl = $self->dq($kid);
3284         $kid = $kid->sibling;
3285     } else {
3286         $repl = $op->pmreplroot->first; # skip substcont
3287         while ($repl->name eq "entereval") {
3288             $repl = $repl->first;
3289             $flags .= "e";
3290         }
3291         if ($op->pmflags & PMf_EVAL) {
3292             $repl = $self->deparse($repl, 0);
3293         } else {
3294             $repl = $self->dq($repl);
3295         }
3296     }
3297     if (null $kid) {
3298         $re = re_uninterp(escape_str(re_unback($op->precomp)));
3299     } else {
3300         $re = $self->deparse($kid, 1);
3301     }
3302     $flags .= "e" if $op->pmflags & PMf_EVAL;
3303     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3304     $flags .= "i" if $op->pmflags & PMf_FOLD;
3305     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3306     $flags .= "o" if $op->pmflags & PMf_KEEP;
3307     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3308     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3309     $flags = $substwords{$flags} if $substwords{$flags};
3310     if ($binop) {
3311         return $self->maybe_parens("$var =~ s"
3312                                    . double_delim($re, $repl) . $flags,
3313                                    $cx, 20);
3314     } else {
3315         return "s". double_delim($re, $repl) . $flags;
3316     }
3317 }
3318
3319 1;
3320 __END__
3321
3322 =head1 NAME
3323
3324 B::Deparse - Perl compiler backend to produce perl code
3325
3326 =head1 SYNOPSIS
3327
3328 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3329         [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3330
3331 =head1 DESCRIPTION
3332
3333 B::Deparse is a backend module for the Perl compiler that generates
3334 perl source code, based on the internal compiled structure that perl
3335 itself creates after parsing a program. The output of B::Deparse won't
3336 be exactly the same as the original source, since perl doesn't keep
3337 track of comments or whitespace, and there isn't a one-to-one
3338 correspondence between perl's syntactical constructions and their
3339 compiled form, but it will often be close. When you use the B<-p>
3340 option, the output also includes parentheses even when they are not
3341 required by precedence, which can make it easy to see if perl is
3342 parsing your expressions the way you intended.
3343
3344 Please note that this module is mainly new and untested code and is
3345 still under development, so it may change in the future.
3346
3347 =head1 OPTIONS
3348
3349 As with all compiler backend options, these must follow directly after
3350 the '-MO=Deparse', separated by a comma but not any white space.
3351
3352 =over 4
3353
3354 =item B<-l>
3355
3356 Add '#line' declarations to the output based on the line and file
3357 locations of the original code.
3358
3359 =item B<-p>
3360
3361 Print extra parentheses. Without this option, B::Deparse includes
3362 parentheses in its output only when they are needed, based on the
3363 structure of your program. With B<-p>, it uses parentheses (almost)
3364 whenever they would be legal. This can be useful if you are used to
3365 LISP, or if you want to see how perl parses your input. If you say
3366
3367     if ($var & 0x7f == 65) {print "Gimme an A!"}
3368     print ($which ? $a : $b), "\n";
3369     $name = $ENV{USER} or "Bob";
3370
3371 C<B::Deparse,-p> will print
3372
3373     if (($var & 0)) {
3374         print('Gimme an A!')
3375     };
3376     (print(($which ? $a : $b)), '???');
3377     (($name = $ENV{'USER'}) or '???')
3378
3379 which probably isn't what you intended (the C<'???'> is a sign that
3380 perl optimized away a constant value).
3381
3382 =item B<-q>
3383
3384 Expand double-quoted strings into the corresponding combinations of
3385 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3386 instance, print
3387
3388     print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3389
3390 as
3391
3392     print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3393           . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3394
3395 Note that the expanded form represents the way perl handles such
3396 constructions internally -- this option actually turns off the reverse
3397 translation that B::Deparse usually does. On the other hand, note that
3398 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3399 of $y into a string before doing the assignment.
3400
3401 =item B<-f>I<FILE>
3402
3403 Normally, B::Deparse deparses the main code of a program, and all the subs
3404 defined in the same file. To include subs defined in other files, pass the
3405 B<-f> option with the filename. You can pass the B<-f> option several times, to
3406 include more than one secondary file.  (Most of the time you don't want to
3407 use it at all.)  You can also use this option to include subs which are
3408 defined in the scope of a B<#line> directive with two parameters.
3409
3410 =item B<-s>I<LETTERS>
3411
3412 Tweak the style of B::Deparse's output. The letters should follow
3413 directly after the 's', with no space or punctuation. The following
3414 options are available:
3415
3416 =over 4
3417
3418 =item B<C>
3419
3420 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3421
3422     if (...) {
3423          ...
3424     } else {
3425          ...
3426     }
3427
3428 instead of
3429
3430     if (...) {
3431          ...
3432     }
3433     else {
3434          ...
3435     }
3436
3437 The default is not to cuddle.
3438
3439 =item B<i>I<NUMBER>
3440
3441 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3442
3443 =item B<T>
3444
3445 Use tabs for each 8 columns of indent. The default is to use only spaces.
3446 For instance, if the style options are B<-si4T>, a line that's indented
3447 3 times will be preceded by one tab and four spaces; if the options were
3448 B<-si8T>, the same line would be preceded by three tabs.
3449
3450 =item B<v>I<STRING>B<.>
3451
3452 Print I<STRING> for the value of a constant that can't be determined
3453 because it was optimized away (mnemonic: this happens when a constant
3454 is used in B<v>oid context). The end of the string is marked by a period.
3455 The string should be a valid perl expression, generally a constant.
3456 Note that unless it's a number, it probably needs to be quoted, and on
3457 a command line quotes need to be protected from the shell. Some
3458 conventional values include 0, 1, 42, '', 'foo', and
3459 'Useless use of constant omitted' (which may need to be
3460 B<-sv"'Useless use of constant omitted'.">
3461 or something similar depending on your shell). The default is '???'.
3462 If you're using B::Deparse on a module or other file that's require'd,
3463 you shouldn't use a value that evaluates to false, since the customary
3464 true constant at the end of a module will be in void context when the
3465 file is compiled as a main program.
3466
3467 =back
3468
3469 =item B<-x>I<LEVEL>
3470
3471 Expand conventional syntax constructions into equivalent ones that expose
3472 their internal operation. I<LEVEL> should be a digit, with higher values
3473 meaning more expansion. As with B<-q>, this actually involves turning off
3474 special cases in B::Deparse's normal operations.
3475
3476 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3477 while loops with continue blocks; for instance
3478
3479     for ($i = 0; $i < 10; ++$i) {
3480         print $i;
3481     }
3482
3483 turns into
3484
3485     $i = 0;
3486     while ($i < 10) {
3487         print $i;
3488     } continue {
3489         ++$i
3490     }
3491
3492 Note that in a few cases this translation can't be perfectly carried back
3493 into the source code -- if the loop's initializer declares a my variable,
3494 for instance, it won't have the correct scope outside of the loop.
3495
3496 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3497 expressions using C<&&>, C<?:> and C<do {}>; for instance
3498
3499     print 'hi' if $nice;
3500     if ($nice) {
3501         print 'hi';
3502     }
3503     if ($nice) {
3504         print 'hi';
3505     } else {
3506         print 'bye';
3507     }
3508
3509 turns into
3510
3511     $nice and print 'hi';
3512     $nice and do { print 'hi' };
3513     $nice ? do { print 'hi' } : do { print 'bye' };
3514
3515 Long sequences of elsifs will turn into nested ternary operators, which
3516 B::Deparse doesn't know how to indent nicely.
3517
3518 =back
3519
3520 =head1 USING B::Deparse AS A MODULE
3521
3522 =head2 Synopsis
3523
3524     use B::Deparse;
3525     $deparse = B::Deparse->new("-p", "-sC");
3526     $body = $deparse->coderef2text(\&func);
3527     eval "sub func $body"; # the inverse operation
3528
3529 =head2 Description
3530
3531 B::Deparse can also be used on a sub-by-sub basis from other perl
3532 programs.
3533
3534 =head2 new
3535
3536     $deparse = B::Deparse->new(OPTIONS)
3537
3538 Create an object to store the state of a deparsing operation and any
3539 options. The options are the same as those that can be given on the
3540 command line (see L</OPTIONS>); options that are separated by commas
3541 after B<-MO=Deparse> should be given as separate strings. Some
3542 options, like B<-u>, don't make sense for a single subroutine, so
3543 don't pass them.
3544
3545 =head2 ambient_pragmas
3546
3547     $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3548
3549 The compilation of a subroutine can be affected by a few compiler
3550 directives, B<pragmas>. These are:
3551
3552 =over 4
3553
3554 =item *
3555
3556 use strict;
3557
3558 =item *
3559
3560 use warnings;
3561
3562 =item *
3563
3564 Assigning to the special variable $[
3565
3566 =item *
3567
3568 use integer;
3569
3570 =item *
3571
3572 use bytes;
3573
3574 =item *
3575
3576 use utf8;
3577
3578 =item *
3579
3580 use re;
3581
3582 =back
3583
3584 Ordinarily, if you use B::Deparse on a subroutine which has
3585 been compiled in the presence of one or more of these pragmas,
3586 the output will include statements to turn on the appropriate
3587 directives. So if you then compile the code returned by coderef2text,
3588 it will behave the same way as the subroutine which you deparsed.
3589
3590 However, you may know that you intend to use the results in a
3591 particular context, where some pragmas are already in scope. In
3592 this case, you use the B<ambient_pragmas> method to describe the
3593 assumptions you wish to make.
3594
3595 The parameters it accepts are:
3596
3597 =over 4
3598
3599 =item strict
3600
3601 Takes a string, possibly containing several values separated
3602 by whitespace. The special values "all" and "none" mean what you'd
3603 expect.
3604
3605     $deparse->ambient_pragmas(strict => 'subs refs');
3606
3607 =item $[
3608
3609 Takes a number, the value of the array base $[.
3610
3611 =item bytes
3612
3613 =item utf8
3614
3615 =item integer
3616
3617 If the value is true, then the appropriate pragma is assumed to
3618 be in the ambient scope, otherwise not.
3619
3620 =item re
3621
3622 Takes a string, possibly containing a whitespace-separated list of
3623 values. The values "all" and "none" are special. It's also permissible
3624 to pass an array reference here.
3625
3626     $deparser->ambient_pragmas(re => 'eval');
3627
3628
3629 =item warnings
3630
3631 Takes a string, possibly containing a whitespace-separated list of
3632 values. The values "all" and "none" are special, again. It's also
3633 permissible to pass an array reference here.
3634
3635     $deparser->ambient_pragmas(warnings => [qw[void io]]);
3636
3637 If one of the values is the string "FATAL", then all the warnings
3638 in that list will be considered fatal, just as with the B<warnings>
3639 pragma itself. Should you need to specify that some warnings are
3640 fatal, and others are merely enabled, you can pass the B<warnings>
3641 parameter twice:
3642
3643     $deparser->ambient_pragmas(
3644         warnings => 'all',
3645         warnings => [FATAL => qw/void io/],
3646     );
3647
3648 See L<perllexwarn> for more information about lexical warnings.
3649
3650 =item hint_bits
3651
3652 =item warning_bits
3653
3654 These two parameters are used to specify the ambient pragmas in
3655 the format used by the special variables $^H and ${^WARNING_BITS}.
3656
3657 They exist principally so that you can write code like:
3658
3659     { my ($hint_bits, $warning_bits);
3660     BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
3661     $deparser->ambient_pragmas (
3662         hint_bits    => $hint_bits,
3663         warning_bits => $warning_bits,
3664         '$['         => 0 + $[
3665     ); }
3666
3667 which specifies that the ambient pragmas are exactly those which
3668 are in scope at the point of calling.
3669
3670 =back
3671
3672 =head2 coderef2text
3673
3674     $body = $deparse->coderef2text(\&func)
3675     $body = $deparse->coderef2text(sub ($$) { ... })
3676
3677 Return source code for the body of a subroutine (a block, optionally
3678 preceded by a prototype in parens), given a reference to the
3679 sub. Because a subroutine can have no names, or more than one name,
3680 this method doesn't return a complete subroutine definition -- if you
3681 want to eval the result, you should prepend "sub subname ", or "sub "
3682 for an anonymous function constructor. Unless the sub was defined in
3683 the main:: package, the code will include a package declaration.
3684
3685 =head1 BUGS
3686
3687 See the 'to do' list at the beginning of the module file.
3688
3689 =head1 AUTHOR
3690
3691 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
3692 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3693 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3694 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.
3695
3696 =cut