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/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/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/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2765     $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2766     return $str;
2767 }
2768
2769 # character escapes, but not delimiters that might need to be escaped
2770 sub escape_str { # ASCII, UTF8
2771     my($str) = @_;
2772     $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
2773     $str =~ s/\a/\\a/g;
2774 #    $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2775     $str =~ s/\t/\\t/g;
2776     $str =~ s/\n/\\n/g;
2777     $str =~ s/\e/\\e/g;
2778     $str =~ s/\f/\\f/g;
2779     $str =~ s/\r/\\r/g;
2780     $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2781     $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2782     return $str;
2783 }
2784
2785 # Don't do this for regexen
2786 sub unback {
2787     my($str) = @_;
2788     $str =~ s/\\/\\\\/g;
2789     return $str;
2790 }
2791
2792 # Remove backslashes which precede literal control characters,
2793 # to avoid creating ambiguity when we escape the latter.
2794 sub re_unback {
2795     my($str) = @_;
2796
2797     # the insane complexity here is due to the behaviour of "\c\"
2798     $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
2799     return $str;
2800 }
2801
2802 sub balanced_delim {
2803     my($str) = @_;
2804     my @str = split //, $str;
2805     my($ar, $open, $close, $fail, $c, $cnt);
2806     for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2807         ($open, $close) = @$ar;
2808         $fail = 0; $cnt = 0;
2809         for $c (@str) {
2810             if ($c eq $open) {
2811                 $cnt++;
2812             } elsif ($c eq $close) {
2813                 $cnt--;
2814                 if ($cnt < 0) {
2815                     # qq()() isn't ")("
2816                     $fail = 1;
2817                     last;
2818                 }
2819             }
2820         }
2821         $fail = 1 if $cnt != 0;
2822         return ($open, "$open$str$close") if not $fail;
2823     }
2824     return ("", $str);
2825 }
2826
2827 sub single_delim {
2828     my($q, $default, $str) = @_;
2829     return "$default$str$default" if $default and index($str, $default) == -1;
2830     my($succeed, $delim);
2831     ($succeed, $str) = balanced_delim($str);
2832     return "$q$str" if $succeed;
2833     for $delim ('/', '"', '#') {
2834         return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2835     }
2836     if ($default) {
2837         $str =~ s/$default/\\$default/g;
2838         return "$default$str$default";
2839     } else {
2840         $str =~ s[/][\\/]g;
2841         return "$q/$str/";
2842     }
2843 }
2844
2845 sub const {
2846     my $sv = shift;
2847     if (class($sv) eq "SPECIAL") {
2848         return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2849     } elsif (class($sv) eq "NULL") {
2850        return 'undef';
2851     } elsif ($sv->FLAGS & SVf_IOK) {
2852         return $sv->int_value;
2853     } elsif ($sv->FLAGS & SVf_NOK) {
2854         return $sv->NV;
2855     } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
2856         return "\\(" . const($sv->RV) . ")"; # constant folded
2857     } else {
2858         my $str = $sv->PV;
2859         if ($str =~ /[^ -~]/) { # ASCII for non-printing
2860             return single_delim("qq", '"', uninterp escape_str unback $str);
2861         } else {
2862             return single_delim("q", "'", unback $str);
2863         }
2864     }
2865 }
2866
2867 sub const_sv {
2868     my $self = shift;
2869     my $op = shift;
2870     my $sv = $op->sv;
2871     # the constant could be in the pad (under useithreads)
2872     $sv = $self->padval($op->targ) unless $$sv;
2873     return $sv;
2874 }
2875
2876 sub pp_const {
2877     my $self = shift;
2878     my($op, $cx) = @_;
2879     if ($op->private & OPpCONST_ARYBASE) {
2880         return '$[';
2881     }
2882 #    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2883 #       return $self->const_sv($op)->PV;
2884 #    }
2885     my $sv = $self->const_sv($op);
2886 #    return const($sv);
2887     my $c = const $sv;
2888     return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
2889 }
2890
2891 sub dq {
2892     my $self = shift;
2893     my $op = shift;
2894     my $type = $op->name;
2895     if ($type eq "const") {
2896         return '$[' if $op->private & OPpCONST_ARYBASE;
2897         return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
2898     } elsif ($type eq "concat") {
2899         my $first = $self->dq($op->first);
2900         my $last  = $self->dq($op->last);
2901         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2902         if ($last =~ /^[A-Z\\\^\[\]_?]/) {
2903             $first =~ s/([\$@])\^$/${1}{^}/;  # "${^}W" etc
2904         }
2905         elsif ($last =~ /^[{\[\w]/) {
2906             $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2907         }
2908         return $first . $last;
2909     } elsif ($type eq "uc") {
2910         return '\U' . $self->dq($op->first->sibling) . '\E';
2911     } elsif ($type eq "lc") {
2912         return '\L' . $self->dq($op->first->sibling) . '\E';
2913     } elsif ($type eq "ucfirst") {
2914         return '\u' . $self->dq($op->first->sibling);
2915     } elsif ($type eq "lcfirst") {
2916         return '\l' . $self->dq($op->first->sibling);
2917     } elsif ($type eq "quotemeta") {
2918         return '\Q' . $self->dq($op->first->sibling) . '\E';
2919     } elsif ($type eq "join") {
2920         return $self->deparse($op->last, 26); # was join($", @ary)
2921     } else {
2922         return $self->deparse($op, 26);
2923     }
2924 }
2925
2926 sub pp_backtick {
2927     my $self = shift;
2928     my($op, $cx) = @_;
2929     # skip pushmark
2930     return single_delim("qx", '`', $self->dq($op->first->sibling));
2931 }
2932
2933 sub dquote {
2934     my $self = shift;
2935     my($op, $cx) = @_;
2936     my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2937     return $self->deparse($kid, $cx) if $self->{'unquote'};
2938     $self->maybe_targmy($kid, $cx,
2939                         sub {single_delim("qq", '"', $self->dq($_[1]))});
2940 }
2941
2942 # OP_STRINGIFY is a listop, but it only ever has one arg
2943 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2944
2945 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2946 # note that tr(from)/to/ is OK, but not tr/from/(to)
2947 sub double_delim {
2948     my($from, $to) = @_;
2949     my($succeed, $delim);
2950     if ($from !~ m[/] and $to !~ m[/]) {
2951         return "/$from/$to/";
2952     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2953         if (($succeed, $to) = balanced_delim($to) and $succeed) {
2954             return "$from$to";
2955         } else {
2956             for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2957                 return "$from$delim$to$delim" if index($to, $delim) == -1;
2958             }
2959             $to =~ s[/][\\/]g;
2960             return "$from/$to/";
2961         }
2962     } else {
2963         for $delim ('/', '"', '#') { # note no '
2964             return "$delim$from$delim$to$delim"
2965                 if index($to . $from, $delim) == -1;
2966         }
2967         $from =~ s[/][\\/]g;
2968         $to =~ s[/][\\/]g;
2969         return "/$from/$to/";
2970     }
2971 }
2972
2973 sub pchr { # ASCII
2974     my($n) = @_;
2975     if ($n == ord '\\') {
2976         return '\\\\';
2977     } elsif ($n >= ord(' ') and $n <= ord('~')) {
2978         return chr($n);
2979     } elsif ($n == ord "\a") {
2980         return '\\a';
2981     } elsif ($n == ord "\b") {
2982         return '\\b';
2983     } elsif ($n == ord "\t") {
2984         return '\\t';
2985     } elsif ($n == ord "\n") {
2986         return '\\n';
2987     } elsif ($n == ord "\e") {
2988         return '\\e';
2989     } elsif ($n == ord "\f") {
2990         return '\\f';
2991     } elsif ($n == ord "\r") {
2992         return '\\r';
2993     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2994         return '\\c' . chr(ord("@") + $n);
2995     } else {
2996 #       return '\x' . sprintf("%02x", $n);
2997         return '\\' . sprintf("%03o", $n);
2998     }
2999 }
3000
3001 sub collapse {
3002     my(@chars) = @_;
3003     my($str, $c, $tr) = ("");
3004     for ($c = 0; $c < @chars; $c++) {
3005         $tr = $chars[$c];
3006         $str .= pchr($tr);
3007         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3008             $chars[$c + 2] == $tr + 2)
3009         {
3010             for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3011               {}
3012             $str .= "-";
3013             $str .= pchr($chars[$c]);
3014         }
3015     }
3016     return $str;
3017 }
3018
3019 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
3020 # and backslashes.
3021
3022 sub tr_decode_byte {
3023     my($table, $flags) = @_;
3024     my(@table) = unpack("s256", $table);
3025     my($c, $tr, @from, @to, @delfrom, $delhyphen);
3026     if ($table[ord "-"] != -1 and
3027         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3028     {
3029         $tr = $table[ord "-"];
3030         $table[ord "-"] = -1;
3031         if ($tr >= 0) {
3032             @from = ord("-");
3033             @to = $tr;
3034         } else { # -2 ==> delete
3035             $delhyphen = 1;
3036         }
3037     }
3038     for ($c = 0; $c < 256; $c++) {
3039         $tr = $table[$c];
3040         if ($tr >= 0) {
3041             push @from, $c; push @to, $tr;
3042         } elsif ($tr == -2) {
3043             push @delfrom, $c;
3044         }
3045     }
3046     @from = (@from, @delfrom);
3047     if ($flags & OPpTRANS_COMPLEMENT) {
3048         my @newfrom = ();
3049         my %from;
3050         @from{@from} = (1) x @from;
3051         for ($c = 0; $c < 256; $c++) {
3052             push @newfrom, $c unless $from{$c};
3053         }
3054         @from = @newfrom;
3055     }
3056     unless ($flags & OPpTRANS_DELETE || !@to) {
3057         pop @to while $#to and $to[$#to] == $to[$#to -1];
3058     }
3059     my($from, $to);
3060     $from = collapse(@from);
3061     $to = collapse(@to);
3062     $from .= "-" if $delhyphen;
3063     return ($from, $to);
3064 }
3065
3066 sub tr_chr {
3067     my $x = shift;
3068     if ($x == ord "-") {
3069         return "\\-";
3070     } else {
3071         return chr $x;
3072     }
3073 }
3074
3075 # XXX This doesn't yet handle all cases correctly either
3076
3077 sub tr_decode_utf8 {
3078     my($swash_hv, $flags) = @_;
3079     my %swash = $swash_hv->ARRAY;
3080     my $final = undef;
3081     $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3082     my $none = $swash{"NONE"}->IV;
3083     my $extra = $none + 1;
3084     my(@from, @delfrom, @to);
3085     my $line;
3086     foreach $line (split /\n/, $swash{'LIST'}->PV) {
3087         my($min, $max, $result) = split(/\t/, $line);
3088         $min = hex $min;
3089         if (length $max) {
3090             $max = hex $max;
3091         } else {
3092             $max = $min;
3093         }
3094         $result = hex $result;
3095         if ($result == $extra) {
3096             push @delfrom, [$min, $max];
3097         } else {
3098             push @from, [$min, $max];
3099             push @to, [$result, $result + $max - $min];
3100         }
3101     }
3102     for my $i (0 .. $#from) {
3103         if ($from[$i][0] == ord '-') {
3104             unshift @from, splice(@from, $i, 1);
3105             unshift @to, splice(@to, $i, 1);
3106             last;
3107         } elsif ($from[$i][1] == ord '-') {
3108             $from[$i][1]--;
3109             $to[$i][1]--;
3110             unshift @from, ord '-';
3111             unshift @to, ord '-';
3112             last;
3113         }
3114     }
3115     for my $i (0 .. $#delfrom) {
3116         if ($delfrom[$i][0] == ord '-') {
3117             push @delfrom, splice(@delfrom, $i, 1);
3118             last;
3119         } elsif ($delfrom[$i][1] == ord '-') {
3120             $delfrom[$i][1]--;
3121             push @delfrom, ord '-';
3122             last;
3123         }
3124     }
3125     if (defined $final and $to[$#to][1] != $final) {
3126         push @to, [$final, $final];
3127     }
3128     push @from, @delfrom;
3129     if ($flags & OPpTRANS_COMPLEMENT) {
3130         my @newfrom;
3131         my $next = 0;
3132         for my $i (0 .. $#from) {
3133             push @newfrom, [$next, $from[$i][0] - 1];
3134             $next = $from[$i][1] + 1;
3135         }
3136         @from = ();
3137         for my $range (@newfrom) {
3138             if ($range->[0] <= $range->[1]) {
3139                 push @from, $range;
3140             }
3141         }
3142     }
3143     my($from, $to, $diff);
3144     for my $chunk (@from) {
3145         $diff = $chunk->[1] - $chunk->[0];
3146         if ($diff > 1) {
3147             $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3148         } elsif ($diff == 1) {
3149             $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3150         } else {
3151             $from .= tr_chr($chunk->[0]);
3152         }
3153     }
3154     for my $chunk (@to) {
3155         $diff = $chunk->[1] - $chunk->[0];
3156         if ($diff > 1) {
3157             $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3158         } elsif ($diff == 1) {
3159             $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3160         } else {
3161             $to .= tr_chr($chunk->[0]);
3162         }
3163     }
3164     #$final = sprintf("%04x", $final) if defined $final;
3165     #$none = sprintf("%04x", $none) if defined $none;
3166     #$extra = sprintf("%04x", $extra) if defined $extra;
3167     #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3168     #print STDERR $swash{'LIST'}->PV;
3169     return (escape_str($from), escape_str($to));
3170 }
3171
3172 sub pp_trans {
3173     my $self = shift;
3174     my($op, $cx) = @_;
3175     my($from, $to);
3176     if (class($op) eq "PVOP") {
3177         ($from, $to) = tr_decode_byte($op->pv, $op->private);
3178     } else { # class($op) eq "SVOP"
3179         ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3180     }
3181     my $flags = "";
3182     $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3183     $flags .= "d" if $op->private & OPpTRANS_DELETE;
3184     $to = "" if $from eq $to and $flags eq "";
3185     $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3186     return "tr" . double_delim($from, $to) . $flags;
3187 }
3188
3189 # Like dq(), but different
3190 sub re_dq {
3191     my $self = shift;
3192     my $op = shift;
3193     my $type = $op->name;
3194     if ($type eq "const") {
3195         return '$[' if $op->private & OPpCONST_ARYBASE;
3196         return re_uninterp(escape_str(re_unback($self->const_sv($op)->as_string)));
3197     } elsif ($type eq "concat") {
3198         my $first = $self->re_dq($op->first);
3199         my $last  = $self->re_dq($op->last);
3200         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3201         if ($last =~ /^[A-Z\\\^\[\]_?]/) {
3202             $first =~ s/([\$@])\^$/${1}{^}/;
3203         }
3204         elsif ($last =~ /^[{\[\w]/) {
3205             $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
3206         }
3207         return $first . $last;
3208     } elsif ($type eq "uc") {
3209         return '\U' . $self->re_dq($op->first->sibling) . '\E';
3210     } elsif ($type eq "lc") {
3211         return '\L' . $self->re_dq($op->first->sibling) . '\E';
3212     } elsif ($type eq "ucfirst") {
3213         return '\u' . $self->re_dq($op->first->sibling);
3214     } elsif ($type eq "lcfirst") {
3215         return '\l' . $self->re_dq($op->first->sibling);
3216     } elsif ($type eq "quotemeta") {
3217         return '\Q' . $self->re_dq($op->first->sibling) . '\E';
3218     } elsif ($type eq "join") {
3219         return $self->deparse($op->last, 26); # was join($", @ary)
3220     } else {
3221         return $self->deparse($op, 26);
3222     }
3223 }
3224
3225 sub pp_regcomp {
3226     my $self = shift;
3227     my($op, $cx) = @_;
3228     my $kid = $op->first;
3229     $kid = $kid->first if $kid->name eq "regcmaybe";
3230     $kid = $kid->first if $kid->name eq "regcreset";
3231     return $self->re_dq($kid);
3232 }
3233
3234 # osmic acid -- see osmium tetroxide
3235
3236 my %matchwords;
3237 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3238     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3239     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3240
3241 sub matchop {
3242     my $self = shift;
3243     my($op, $cx, $name, $delim) = @_;
3244     my $kid = $op->first;
3245     my ($binop, $var, $re) = ("", "", "");
3246     if ($op->flags & OPf_STACKED) {
3247         $binop = 1;
3248         $var = $self->deparse($kid, 20);
3249         $kid = $kid->sibling;
3250     }
3251     if (null $kid) {
3252         $re = re_uninterp(escape_str(re_unback($op->precomp)));
3253     } else {
3254         $re = $self->deparse($kid, 1);
3255     }
3256     my $flags = "";
3257     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3258     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3259     $flags .= "i" if $op->pmflags & PMf_FOLD;
3260     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3261     $flags .= "o" if $op->pmflags & PMf_KEEP;
3262     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3263     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3264     $flags = $matchwords{$flags} if $matchwords{$flags};
3265     if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3266         $re =~ s/\?/\\?/g;
3267         $re = "?$re?";
3268     } else {
3269         $re = single_delim($name, $delim, $re);
3270     }
3271     $re = $re . $flags;
3272     if ($binop) {
3273         return $self->maybe_parens("$var =~ $re", $cx, 20);
3274     } else {
3275         return $re;
3276     }
3277 }
3278
3279 sub pp_match { matchop(@_, "m", "/") }
3280 sub pp_pushre { matchop(@_, "m", "/") }
3281 sub pp_qr { matchop(@_, "qr", "") }
3282
3283 sub pp_split {
3284     my $self = shift;
3285     my($op, $cx) = @_;
3286     my($kid, @exprs, $ary, $expr);
3287     $kid = $op->first;
3288     if ($ {$kid->pmreplroot}) {
3289         $ary = '@' . $self->gv_name($kid->pmreplroot);
3290     }
3291     for (; !null($kid); $kid = $kid->sibling) {
3292         push @exprs, $self->deparse($kid, 6);
3293     }
3294
3295     # handle special case of split(), and split(" ") that compiles to /\s+/
3296     $kid = $op->first;
3297     if ($kid->flags & OPf_SPECIAL
3298         && $exprs[0] eq '/\\s+/'
3299         && $kid->pmflags & PMf_SKIPWHITE ) {
3300             $exprs[0] = '" "';
3301     }
3302
3303     $expr = "split(" . join(", ", @exprs) . ")";
3304     if ($ary) {
3305         return $self->maybe_parens("$ary = $expr", $cx, 7);
3306     } else {
3307         return $expr;
3308     }
3309 }
3310
3311 # oxime -- any of various compounds obtained chiefly by the action of
3312 # hydroxylamine on aldehydes and ketones and characterized by the
3313 # bivalent grouping C=NOH [Webster's Tenth]
3314
3315 my %substwords;
3316 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3317     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3318     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3319     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3320
3321 sub pp_subst {
3322     my $self = shift;
3323     my($op, $cx) = @_;
3324     my $kid = $op->first;
3325     my($binop, $var, $re, $repl) = ("", "", "", "");
3326     if ($op->flags & OPf_STACKED) {
3327         $binop = 1;
3328         $var = $self->deparse($kid, 20);
3329         $kid = $kid->sibling;
3330     }
3331     my $flags = "";
3332     if (null($op->pmreplroot)) {
3333         $repl = $self->dq($kid);
3334         $kid = $kid->sibling;
3335     } else {
3336         $repl = $op->pmreplroot->first; # skip substcont
3337         while ($repl->name eq "entereval") {
3338             $repl = $repl->first;
3339             $flags .= "e";
3340         }
3341         if ($op->pmflags & PMf_EVAL) {
3342             $repl = $self->deparse($repl, 0);
3343         } else {
3344             $repl = $self->dq($repl);
3345         }
3346     }
3347     if (null $kid) {
3348         $re = re_uninterp(escape_str(re_unback($op->precomp)));
3349     } else {
3350         $re = $self->deparse($kid, 1);
3351     }
3352     $flags .= "e" if $op->pmflags & PMf_EVAL;
3353     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3354     $flags .= "i" if $op->pmflags & PMf_FOLD;
3355     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3356     $flags .= "o" if $op->pmflags & PMf_KEEP;
3357     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3358     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3359     $flags = $substwords{$flags} if $substwords{$flags};
3360     if ($binop) {
3361         return $self->maybe_parens("$var =~ s"
3362                                    . double_delim($re, $repl) . $flags,
3363                                    $cx, 20);
3364     } else {
3365         return "s". double_delim($re, $repl) . $flags;
3366     }
3367 }
3368
3369 1;
3370 __END__
3371
3372 =head1 NAME
3373
3374 B::Deparse - Perl compiler backend to produce perl code
3375
3376 =head1 SYNOPSIS
3377
3378 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3379         [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3380
3381 =head1 DESCRIPTION
3382
3383 B::Deparse is a backend module for the Perl compiler that generates
3384 perl source code, based on the internal compiled structure that perl
3385 itself creates after parsing a program. The output of B::Deparse won't
3386 be exactly the same as the original source, since perl doesn't keep
3387 track of comments or whitespace, and there isn't a one-to-one
3388 correspondence between perl's syntactical constructions and their
3389 compiled form, but it will often be close. When you use the B<-p>
3390 option, the output also includes parentheses even when they are not
3391 required by precedence, which can make it easy to see if perl is
3392 parsing your expressions the way you intended.
3393
3394 Please note that this module is mainly new and untested code and is
3395 still under development, so it may change in the future.
3396
3397 =head1 OPTIONS
3398
3399 As with all compiler backend options, these must follow directly after
3400 the '-MO=Deparse', separated by a comma but not any white space.
3401
3402 =over 4
3403
3404 =item B<-l>
3405
3406 Add '#line' declarations to the output based on the line and file
3407 locations of the original code.
3408
3409 =item B<-p>
3410
3411 Print extra parentheses. Without this option, B::Deparse includes
3412 parentheses in its output only when they are needed, based on the
3413 structure of your program. With B<-p>, it uses parentheses (almost)
3414 whenever they would be legal. This can be useful if you are used to
3415 LISP, or if you want to see how perl parses your input. If you say
3416
3417     if ($var & 0x7f == 65) {print "Gimme an A!"}
3418     print ($which ? $a : $b), "\n";
3419     $name = $ENV{USER} or "Bob";
3420
3421 C<B::Deparse,-p> will print
3422
3423     if (($var & 0)) {
3424         print('Gimme an A!')
3425     };
3426     (print(($which ? $a : $b)), '???');
3427     (($name = $ENV{'USER'}) or '???')
3428
3429 which probably isn't what you intended (the C<'???'> is a sign that
3430 perl optimized away a constant value).
3431
3432 =item B<-q>
3433
3434 Expand double-quoted strings into the corresponding combinations of
3435 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3436 instance, print
3437
3438     print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3439
3440 as
3441
3442     print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3443           . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3444
3445 Note that the expanded form represents the way perl handles such
3446 constructions internally -- this option actually turns off the reverse
3447 translation that B::Deparse usually does. On the other hand, note that
3448 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3449 of $y into a string before doing the assignment.
3450
3451 =item B<-f>I<FILE>
3452
3453 Normally, B::Deparse deparses the main code of a program, and all the subs
3454 defined in the same file. To include subs defined in other files, pass the
3455 B<-f> option with the filename. You can pass the B<-f> option several times, to
3456 include more than one secondary file.  (Most of the time you don't want to
3457 use it at all.)  You can also use this option to include subs which are
3458 defined in the scope of a B<#line> directive with two parameters.
3459
3460 =item B<-s>I<LETTERS>
3461
3462 Tweak the style of B::Deparse's output. The letters should follow
3463 directly after the 's', with no space or punctuation. The following
3464 options are available:
3465
3466 =over 4
3467
3468 =item B<C>
3469
3470 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3471
3472     if (...) {
3473          ...
3474     } else {
3475          ...
3476     }
3477
3478 instead of
3479
3480     if (...) {
3481          ...
3482     }
3483     else {
3484          ...
3485     }
3486
3487 The default is not to cuddle.
3488
3489 =item B<i>I<NUMBER>
3490
3491 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3492
3493 =item B<T>
3494
3495 Use tabs for each 8 columns of indent. The default is to use only spaces.
3496 For instance, if the style options are B<-si4T>, a line that's indented
3497 3 times will be preceded by one tab and four spaces; if the options were
3498 B<-si8T>, the same line would be preceded by three tabs.
3499
3500 =item B<v>I<STRING>B<.>
3501
3502 Print I<STRING> for the value of a constant that can't be determined
3503 because it was optimized away (mnemonic: this happens when a constant
3504 is used in B<v>oid context). The end of the string is marked by a period.
3505 The string should be a valid perl expression, generally a constant.
3506 Note that unless it's a number, it probably needs to be quoted, and on
3507 a command line quotes need to be protected from the shell. Some
3508 conventional values include 0, 1, 42, '', 'foo', and
3509 'Useless use of constant omitted' (which may need to be
3510 B<-sv"'Useless use of constant omitted'.">
3511 or something similar depending on your shell). The default is '???'.
3512 If you're using B::Deparse on a module or other file that's require'd,
3513 you shouldn't use a value that evaluates to false, since the customary
3514 true constant at the end of a module will be in void context when the
3515 file is compiled as a main program.
3516
3517 =back
3518
3519 =item B<-x>I<LEVEL>
3520
3521 Expand conventional syntax constructions into equivalent ones that expose
3522 their internal operation. I<LEVEL> should be a digit, with higher values
3523 meaning more expansion. As with B<-q>, this actually involves turning off
3524 special cases in B::Deparse's normal operations.
3525
3526 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3527 while loops with continue blocks; for instance
3528
3529     for ($i = 0; $i < 10; ++$i) {
3530         print $i;
3531     }
3532
3533 turns into
3534
3535     $i = 0;
3536     while ($i < 10) {
3537         print $i;
3538     } continue {
3539         ++$i
3540     }
3541
3542 Note that in a few cases this translation can't be perfectly carried back
3543 into the source code -- if the loop's initializer declares a my variable,
3544 for instance, it won't have the correct scope outside of the loop.
3545
3546 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3547 expressions using C<&&>, C<?:> and C<do {}>; for instance
3548
3549     print 'hi' if $nice;
3550     if ($nice) {
3551         print 'hi';
3552     }
3553     if ($nice) {
3554         print 'hi';
3555     } else {
3556         print 'bye';
3557     }
3558
3559 turns into
3560
3561     $nice and print 'hi';
3562     $nice and do { print 'hi' };
3563     $nice ? do { print 'hi' } : do { print 'bye' };
3564
3565 Long sequences of elsifs will turn into nested ternary operators, which
3566 B::Deparse doesn't know how to indent nicely.
3567
3568 =back
3569
3570 =head1 USING B::Deparse AS A MODULE
3571
3572 =head2 Synopsis
3573
3574     use B::Deparse;
3575     $deparse = B::Deparse->new("-p", "-sC");
3576     $body = $deparse->coderef2text(\&func);
3577     eval "sub func $body"; # the inverse operation
3578
3579 =head2 Description
3580
3581 B::Deparse can also be used on a sub-by-sub basis from other perl
3582 programs.
3583
3584 =head2 new
3585
3586     $deparse = B::Deparse->new(OPTIONS)
3587
3588 Create an object to store the state of a deparsing operation and any
3589 options. The options are the same as those that can be given on the
3590 command line (see L</OPTIONS>); options that are separated by commas
3591 after B<-MO=Deparse> should be given as separate strings. Some
3592 options, like B<-u>, don't make sense for a single subroutine, so
3593 don't pass them.
3594
3595 =head2 ambient_pragmas
3596
3597     $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3598
3599 The compilation of a subroutine can be affected by a few compiler
3600 directives, B<pragmas>. These are:
3601
3602 =over 4
3603
3604 =item *
3605
3606 use strict;
3607
3608 =item *
3609
3610 use warnings;
3611
3612 =item *
3613
3614 Assigning to the special variable $[
3615
3616 =item *
3617
3618 use integer;
3619
3620 =item *
3621
3622 use bytes;
3623
3624 =item *
3625
3626 use utf8;
3627
3628 =item *
3629
3630 use re;
3631
3632 =back
3633
3634 Ordinarily, if you use B::Deparse on a subroutine which has
3635 been compiled in the presence of one or more of these pragmas,
3636 the output will include statements to turn on the appropriate
3637 directives. So if you then compile the code returned by coderef2text,
3638 it will behave the same way as the subroutine which you deparsed.
3639
3640 However, you may know that you intend to use the results in a
3641 particular context, where some pragmas are already in scope. In
3642 this case, you use the B<ambient_pragmas> method to describe the
3643 assumptions you wish to make.
3644
3645 The parameters it accepts are:
3646
3647 =over 4
3648
3649 =item strict
3650
3651 Takes a string, possibly containing several values separated
3652 by whitespace. The special values "all" and "none" mean what you'd
3653 expect.
3654
3655     $deparse->ambient_pragmas(strict => 'subs refs');
3656
3657 =item $[
3658
3659 Takes a number, the value of the array base $[.
3660
3661 =item bytes
3662
3663 =item utf8
3664
3665 =item integer
3666
3667 If the value is true, then the appropriate pragma is assumed to
3668 be in the ambient scope, otherwise not.
3669
3670 =item re
3671
3672 Takes a string, possibly containing a whitespace-separated list of
3673 values. The values "all" and "none" are special. It's also permissible
3674 to pass an array reference here.
3675
3676     $deparser->ambient_pragmas(re => 'eval');
3677
3678
3679 =item warnings
3680
3681 Takes a string, possibly containing a whitespace-separated list of
3682 values. The values "all" and "none" are special, again. It's also
3683 permissible to pass an array reference here.
3684
3685     $deparser->ambient_pragmas(warnings => [qw[void io]]);
3686
3687 If one of the values is the string "FATAL", then all the warnings
3688 in that list will be considered fatal, just as with the B<warnings>
3689 pragma itself. Should you need to specify that some warnings are
3690 fatal, and others are merely enabled, you can pass the B<warnings>
3691 parameter twice:
3692
3693     $deparser->ambient_pragmas(
3694         warnings => 'all',
3695         warnings => [FATAL => qw/void io/],
3696     );
3697
3698 See L<perllexwarn> for more information about lexical warnings.
3699
3700 =item hint_bits
3701
3702 =item warning_bits
3703
3704 These two parameters are used to specify the ambient pragmas in
3705 the format used by the special variables $^H and ${^WARNING_BITS}.
3706
3707 They exist principally so that you can write code like:
3708
3709     { my ($hint_bits, $warning_bits);
3710     BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
3711     $deparser->ambient_pragmas (
3712         hint_bits    => $hint_bits,
3713         warning_bits => $warning_bits,
3714         '$['         => 0 + $[
3715     ); }
3716
3717 which specifies that the ambient pragmas are exactly those which
3718 are in scope at the point of calling.
3719
3720 =back
3721
3722 =head2 coderef2text
3723
3724     $body = $deparse->coderef2text(\&func)
3725     $body = $deparse->coderef2text(sub ($$) { ... })
3726
3727 Return source code for the body of a subroutine (a block, optionally
3728 preceded by a prototype in parens), given a reference to the
3729 sub. Because a subroutine can have no names, or more than one name,
3730 this method doesn't return a complete subroutine definition -- if you
3731 want to eval the result, you should prepend "sub subname ", or "sub "
3732 for an anonymous function constructor. Unless the sub was defined in
3733 the main:: package, the code will include a package declaration.
3734
3735 =head1 BUGS
3736
3737 See the 'to do' list at the beginning of the module file.
3738
3739 =head1 AUTHOR
3740
3741 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
3742 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3743 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3744 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.
3745
3746 =cut