ext/B/B/Deparse.pm

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