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