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             if (class($ns[$i]) eq "PV") {
1101                 # Probably that pesky lexical @_
1102                 next;
1103             }
1104             my $name = $ns[$i]->PVX;
1105             my $seq_st = $ns[$i]->NVX;
1106             my $seq_en = int($ns[$i]->IVX);
1107
1108             push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
1109         }
1110     }
1111 }
1112
1113 # Recurses down the tree, looking for a COP
1114 sub find_cop {
1115     my ($self, $op) = @_;
1116     if ($op->flags & OPf_KIDS) {
1117         for (my $o=$op->first; $$o; $o=$o->sibling) {
1118             return $o if is_state($o);
1119             my $r = $self->find_cop($o);
1120             return $r if defined $r;
1121         }
1122     }
1123     return undef;
1124 }
1125
1126 # Returns a list of subs which should be inserted before the COP
1127 sub cop_subs {
1128     my ($self, $op, $out_seq) = @_;
1129     my $seq = $op->cop_seq;
1130     # If we have nephews, then our sequence number indicates
1131     # the cop_seq of the end of some sort of scope.
1132     if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1133         and my $ncop = $self->find_cop($op->sibling)) {
1134         $seq = $ncop->cop_seq;
1135     }
1136     $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1137     return $self->seq_subs($seq);
1138 }
1139
1140 sub seq_subs {
1141     my ($self, $seq) = @_;
1142     my @text;
1143 #push @text, "# ($seq)\n";
1144
1145     while (scalar(@{$self->{'subs_todo'}})
1146            and $seq > $self->{'subs_todo'}[0][0]) {
1147         push @text, $self->next_todo;
1148     }
1149     return @text;
1150 }
1151
1152 # Notice how subs and formats are inserted between statements here;
1153 # also $[ assignments and pragmas.
1154 sub pp_nextstate {
1155     my $self = shift;
1156     my($op, $cx) = @_;
1157     $self->{'curcop'} = $op;
1158     my @text;
1159     @text = $op->label . ": " if $op->label;
1160 #push @text, "# ", $op->cop_seq, "\n";
1161     push @text, $self->cop_subs($op);
1162     my $stash = $op->stashpv;
1163     if ($stash ne $self->{'curstash'}) {
1164         push @text, "package $stash;\n";
1165         $self->{'curstash'} = $stash;
1166     }
1167     if ($self->{'linenums'}) {
1168         push @text, "\f#line " . $op->line .
1169           ' "' . $op->file, qq'"\n';
1170     }
1171
1172     if ($self->{'arybase'} != $op->arybase) {
1173         push @text, '$[ = '. $op->arybase .";\n";
1174         $self->{'arybase'} = $op->arybase;
1175     }
1176
1177     my $warnings = $op->warnings;
1178     my $warning_bits;
1179     if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1180         $warning_bits = $warnings::Bits{"all"};
1181     }
1182     elsif ($warnings->isa("B::SPECIAL")) {
1183         $warning_bits = "\0"x12;
1184     }
1185     else {
1186         $warning_bits = $warnings->PV & WARN_MASK;
1187     }
1188
1189     if ($self->{'warnings'} ne $warning_bits) {
1190         push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1191         $self->{'warnings'} = $warning_bits;
1192     }
1193
1194     if ($self->{'hints'} != $op->private) {
1195         push @text, declare_hints($self->{'hints'}, $op->private);
1196         $self->{'hints'} = $op->private;
1197     }
1198
1199     return join("", @text);
1200 }
1201
1202 sub declare_warnings {
1203     my ($from, $to) = @_;
1204     if ($to eq warnings::bits("all")) {
1205         return "use warnings;\n";
1206     }
1207     elsif ($to eq "\0"x12) {
1208         return "no warnings;\n";
1209     }
1210     return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n";
1211 }
1212
1213 sub declare_hints {
1214     my ($from, $to) = @_;
1215     my $bits = $to;
1216     return sprintf "BEGIN {\$^H &= ~0xFF; \$^H |= %x}\n", $bits;
1217 }
1218
1219 sub pp_dbstate { pp_nextstate(@_) }
1220 sub pp_setstate { pp_nextstate(@_) }
1221
1222 sub pp_unstack { return "" } # see also leaveloop
1223
1224 sub baseop {
1225     my $self = shift;
1226     my($op, $cx, $name) = @_;
1227     return $name;
1228 }
1229
1230 sub pp_stub { baseop(@_, "()") }
1231 sub pp_wantarray { baseop(@_, "wantarray") }
1232 sub pp_fork { baseop(@_, "fork") }
1233 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1234 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1235 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1236 sub pp_tms { baseop(@_, "times") }
1237 sub pp_ghostent { baseop(@_, "gethostent") }
1238 sub pp_gnetent { baseop(@_, "getnetent") }
1239 sub pp_gprotoent { baseop(@_, "getprotoent") }
1240 sub pp_gservent { baseop(@_, "getservent") }
1241 sub pp_ehostent { baseop(@_, "endhostent") }
1242 sub pp_enetent { baseop(@_, "endnetent") }
1243 sub pp_eprotoent { baseop(@_, "endprotoent") }
1244 sub pp_eservent { baseop(@_, "endservent") }
1245 sub pp_gpwent { baseop(@_, "getpwent") }
1246 sub pp_spwent { baseop(@_, "setpwent") }
1247 sub pp_epwent { baseop(@_, "endpwent") }
1248 sub pp_ggrent { baseop(@_, "getgrent") }
1249 sub pp_sgrent { baseop(@_, "setgrent") }
1250 sub pp_egrent { baseop(@_, "endgrent") }
1251 sub pp_getlogin { baseop(@_, "getlogin") }
1252
1253 sub POSTFIX () { 1 }
1254
1255 # I couldn't think of a good short name, but this is the category of
1256 # symbolic unary operators with interesting precedence
1257
1258 sub pfixop {
1259     my $self = shift;
1260     my($op, $cx, $name, $prec, $flags) = (@_, 0);
1261     my $kid = $op->first;
1262     $kid = $self->deparse($kid, $prec);
1263     return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1264                                $cx, $prec);
1265 }
1266
1267 sub pp_preinc { pfixop(@_, "++", 23) }
1268 sub pp_predec { pfixop(@_, "--", 23) }
1269 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1270 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1271 sub pp_i_preinc { pfixop(@_, "++", 23) }
1272 sub pp_i_predec { pfixop(@_, "--", 23) }
1273 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1274 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1275 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1276
1277 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1278 sub real_negate {
1279     my $self = shift;
1280     my($op, $cx) = @_;
1281     if ($op->first->name =~ /^(i_)?negate$/) {
1282         # avoid --$x
1283         $self->pfixop($op, $cx, "-", 21.5);
1284     } else {
1285         $self->pfixop($op, $cx, "-", 21);
1286     }
1287 }
1288 sub pp_i_negate { pp_negate(@_) }
1289
1290 sub pp_not {
1291     my $self = shift;
1292     my($op, $cx) = @_;
1293     if ($cx <= 4) {
1294         $self->pfixop($op, $cx, "not ", 4);
1295     } else {
1296         $self->pfixop($op, $cx, "!", 21);
1297     }
1298 }
1299
1300 sub unop {
1301     my $self = shift;
1302     my($op, $cx, $name) = @_;
1303     my $kid;
1304     if ($op->flags & OPf_KIDS) {
1305         $kid = $op->first;
1306         return $self->maybe_parens_unop($name, $kid, $cx);
1307     } else {
1308         return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");
1309     }
1310 }
1311
1312 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1313 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1314 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1315 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1316 sub pp_defined { unop(@_, "defined") }
1317 sub pp_undef { unop(@_, "undef") }
1318 sub pp_study { unop(@_, "study") }
1319 sub pp_ref { unop(@_, "ref") }
1320 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1321
1322 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1323 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1324 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1325 sub pp_srand { unop(@_, "srand") }
1326 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1327 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1328 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1329 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1330 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1331 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1332 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1333
1334 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1335 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1336 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1337
1338 sub pp_each { unop(@_, "each") }
1339 sub pp_values { unop(@_, "values") }
1340 sub pp_keys { unop(@_, "keys") }
1341 sub pp_pop { unop(@_, "pop") }
1342 sub pp_shift { unop(@_, "shift") }
1343
1344 sub pp_caller { unop(@_, "caller") }
1345 sub pp_reset { unop(@_, "reset") }
1346 sub pp_exit { unop(@_, "exit") }
1347 sub pp_prototype { unop(@_, "prototype") }
1348
1349 sub pp_close { unop(@_, "close") }
1350 sub pp_fileno { unop(@_, "fileno") }
1351 sub pp_umask { unop(@_, "umask") }
1352 sub pp_untie { unop(@_, "untie") }
1353 sub pp_tied { unop(@_, "tied") }
1354 sub pp_dbmclose { unop(@_, "dbmclose") }
1355 sub pp_getc { unop(@_, "getc") }
1356 sub pp_eof { unop(@_, "eof") }
1357 sub pp_tell { unop(@_, "tell") }
1358 sub pp_getsockname { unop(@_, "getsockname") }
1359 sub pp_getpeername { unop(@_, "getpeername") }
1360
1361 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1362 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1363 sub pp_readlink { unop(@_, "readlink") }
1364 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1365 sub pp_readdir { unop(@_, "readdir") }
1366 sub pp_telldir { unop(@_, "telldir") }
1367 sub pp_rewinddir { unop(@_, "rewinddir") }
1368 sub pp_closedir { unop(@_, "closedir") }
1369 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1370 sub pp_localtime { unop(@_, "localtime") }
1371 sub pp_gmtime { unop(@_, "gmtime") }
1372 sub pp_alarm { unop(@_, "alarm") }
1373 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1374
1375 sub pp_dofile { unop(@_, "do") }
1376 sub pp_entereval { unop(@_, "eval") }
1377
1378 sub pp_ghbyname { unop(@_, "gethostbyname") }
1379 sub pp_gnbyname { unop(@_, "getnetbyname") }
1380 sub pp_gpbyname { unop(@_, "getprotobyname") }
1381 sub pp_shostent { unop(@_, "sethostent") }
1382 sub pp_snetent { unop(@_, "setnetent") }
1383 sub pp_sprotoent { unop(@_, "setprotoent") }
1384 sub pp_sservent { unop(@_, "setservent") }
1385 sub pp_gpwnam { unop(@_, "getpwnam") }
1386 sub pp_gpwuid { unop(@_, "getpwuid") }
1387 sub pp_ggrnam { unop(@_, "getgrnam") }
1388 sub pp_ggrgid { unop(@_, "getgrgid") }
1389
1390 sub pp_lock { unop(@_, "lock") }
1391
1392 sub pp_exists {
1393     my $self = shift;
1394     my($op, $cx) = @_;
1395     my $arg;
1396     if ($op->private & OPpEXISTS_SUB) {
1397         # Checking for the existence of a subroutine
1398         return $self->maybe_parens_func("exists",
1399                                 $self->pp_rv2cv($op->first, 16), $cx, 16);
1400     }
1401     if ($op->flags & OPf_SPECIAL) {
1402         # Array element, not hash element
1403         return $self->maybe_parens_func("exists",
1404                                 $self->pp_aelem($op->first, 16), $cx, 16);
1405     }
1406     return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1407                                     $cx, 16);
1408 }
1409
1410 sub pp_delete {
1411     my $self = shift;
1412     my($op, $cx) = @_;
1413     my $arg;
1414     if ($op->private & OPpSLICE) {
1415         if ($op->flags & OPf_SPECIAL) {
1416             # Deleting from an array, not a hash
1417             return $self->maybe_parens_func("delete",
1418                                         $self->pp_aslice($op->first, 16),
1419                                         $cx, 16);
1420         }
1421         return $self->maybe_parens_func("delete",
1422                                         $self->pp_hslice($op->first, 16),
1423                                         $cx, 16);
1424     } else {
1425         if ($op->flags & OPf_SPECIAL) {
1426             # Deleting from an array, not a hash
1427             return $self->maybe_parens_func("delete",
1428                                         $self->pp_aelem($op->first, 16),
1429                                         $cx, 16);
1430         }
1431         return $self->maybe_parens_func("delete",
1432                                         $self->pp_helem($op->first, 16),
1433                                         $cx, 16);
1434     }
1435 }
1436
1437 sub pp_require {
1438     my $self = shift;
1439     my($op, $cx) = @_;
1440     if (class($op) eq "UNOP" and $op->first->name eq "const"
1441         and $op->first->private & OPpCONST_BARE)
1442     {
1443         my $name = $self->const_sv($op->first)->PV;
1444         $name =~ s[/][::]g;
1445         $name =~ s/\.pm//g;
1446         return "require $name";
1447     } else {
1448         $self->unop($op, $cx, "require");
1449     }
1450 }
1451
1452 sub pp_scalar {
1453     my $self = shift;
1454     my($op, $cv) = @_;
1455     my $kid = $op->first;
1456     if (not null $kid->sibling) {
1457         # XXX Was a here-doc
1458         return $self->dquote($op);
1459     }
1460     $self->unop(@_, "scalar");
1461 }
1462
1463
1464 sub padval {
1465     my $self = shift;
1466     my $targ = shift;
1467     #cluck "curcv was undef" unless $self->{curcv};
1468     return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1469 }
1470
1471 sub pp_refgen {
1472     my $self = shift;
1473     my($op, $cx) = @_;
1474     my $kid = $op->first;
1475     if ($kid->name eq "null") {
1476         $kid = $kid->first;
1477         if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1478             my($pre, $post) = @{{"anonlist" => ["[","]"],
1479                                  "anonhash" => ["{","}"]}->{$kid->name}};
1480             my($expr, @exprs);
1481             $kid = $kid->first->sibling; # skip pushmark
1482             for (; !null($kid); $kid = $kid->sibling) {
1483                 $expr = $self->deparse($kid, 6);
1484                 push @exprs, $expr;
1485             }
1486             return $pre . join(", ", @exprs) . $post;
1487         } elsif (!null($kid->sibling) and
1488                  $kid->sibling->name eq "anoncode") {
1489             return "sub " .
1490                 $self->deparse_sub($self->padval($kid->sibling->targ));
1491         } elsif ($kid->name eq "pushmark") {
1492             my $sib_name = $kid->sibling->name;
1493             if ($sib_name =~ /^(pad|rv2)[ah]v$/
1494                 and not $kid->sibling->flags & OPf_REF)
1495             {
1496                 # The @a in \(@a) isn't in ref context, but only when the
1497                 # parens are there.
1498                 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1499             } elsif ($sib_name eq 'entersub') {
1500                 my $text = $self->deparse($kid->sibling, 1);
1501                 # Always show parens for \(&func()), but only with -p otherwise
1502                 $text = "($text)" if $self->{'parens'}
1503                                  or $kid->sibling->private & OPpENTERSUB_AMPER;
1504                 return "\\$text";
1505             }
1506         }
1507     }
1508     $self->pfixop($op, $cx, "\\", 20);
1509 }
1510
1511 sub pp_srefgen { pp_refgen(@_) }
1512
1513 sub pp_readline {
1514     my $self = shift;
1515     my($op, $cx) = @_;
1516     my $kid = $op->first;
1517     $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1518     return "<" . $self->deparse($kid, 1) . ">";
1519 }
1520
1521 # Unary operators that can occur as pseudo-listops inside double quotes
1522 sub dq_unop {
1523     my $self = shift;
1524     my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1525     my $kid;
1526     if ($op->flags & OPf_KIDS) {
1527        $kid = $op->first;
1528        # If there's more than one kid, the first is an ex-pushmark.
1529        $kid = $kid->sibling if not null $kid->sibling;
1530        return $self->maybe_parens_unop($name, $kid, $cx);
1531     } else {
1532        return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");
1533     }
1534 }
1535
1536 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1537 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1538 sub pp_uc { dq_unop(@_, "uc") }
1539 sub pp_lc { dq_unop(@_, "lc") }
1540 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1541
1542 sub loopex {
1543     my $self = shift;
1544     my ($op, $cx, $name) = @_;
1545     if (class($op) eq "PVOP") {
1546         return "$name " . $op->pv;
1547     } elsif (class($op) eq "OP") {
1548         return $name;
1549     } elsif (class($op) eq "UNOP") {
1550         # Note -- loop exits are actually exempt from the
1551         # looks-like-a-func rule, but a few extra parens won't hurt
1552         return $self->maybe_parens_unop($name, $op->first, $cx);
1553     }
1554 }
1555
1556 sub pp_last { loopex(@_, "last") }
1557 sub pp_next { loopex(@_, "next") }
1558 sub pp_redo { loopex(@_, "redo") }
1559 sub pp_goto { loopex(@_, "goto") }
1560 sub pp_dump { loopex(@_, "dump") }
1561
1562 sub ftst {
1563     my $self = shift;
1564     my($op, $cx, $name) = @_;
1565     if (class($op) eq "UNOP") {
1566         # Genuine `-X' filetests are exempt from the LLAFR, but not
1567         # l?stat(); for the sake of clarity, give'em all parens
1568         return $self->maybe_parens_unop($name, $op->first, $cx);
1569     } elsif (class($op) eq "SVOP") {
1570         return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1571     } else { # I don't think baseop filetests ever survive ck_ftst, but...
1572         return $name;
1573     }
1574 }
1575
1576 sub pp_lstat { ftst(@_, "lstat") }
1577 sub pp_stat { ftst(@_, "stat") }
1578 sub pp_ftrread { ftst(@_, "-R") }
1579 sub pp_ftrwrite { ftst(@_, "-W") }
1580 sub pp_ftrexec { ftst(@_, "-X") }
1581 sub pp_fteread { ftst(@_, "-r") }
1582 sub pp_ftewrite { ftst(@_, "-r") }
1583 sub pp_fteexec { ftst(@_, "-r") }
1584 sub pp_ftis { ftst(@_, "-e") }
1585 sub pp_fteowned { ftst(@_, "-O") }
1586 sub pp_ftrowned { ftst(@_, "-o") }
1587 sub pp_ftzero { ftst(@_, "-z") }
1588 sub pp_ftsize { ftst(@_, "-s") }
1589 sub pp_ftmtime { ftst(@_, "-M") }
1590 sub pp_ftatime { ftst(@_, "-A") }
1591 sub pp_ftctime { ftst(@_, "-C") }
1592 sub pp_ftsock { ftst(@_, "-S") }
1593 sub pp_ftchr { ftst(@_, "-c") }
1594 sub pp_ftblk { ftst(@_, "-b") }
1595 sub pp_ftfile { ftst(@_, "-f") }
1596 sub pp_ftdir { ftst(@_, "-d") }
1597 sub pp_ftpipe { ftst(@_, "-p") }
1598 sub pp_ftlink { ftst(@_, "-l") }
1599 sub pp_ftsuid { ftst(@_, "-u") }
1600 sub pp_ftsgid { ftst(@_, "-g") }
1601 sub pp_ftsvtx { ftst(@_, "-k") }
1602 sub pp_fttty { ftst(@_, "-t") }
1603 sub pp_fttext { ftst(@_, "-T") }
1604 sub pp_ftbinary { ftst(@_, "-B") }
1605
1606 sub SWAP_CHILDREN () { 1 }
1607 sub ASSIGN () { 2 } # has OP= variant
1608
1609 my(%left, %right);
1610
1611 sub assoc_class {
1612     my $op = shift;
1613     my $name = $op->name;
1614     if ($name eq "concat" and $op->first->name eq "concat") {
1615         # avoid spurious `=' -- see comment in pp_concat
1616         return "concat";
1617     }
1618     if ($name eq "null" and class($op) eq "UNOP"
1619         and $op->first->name =~ /^(and|x?or)$/
1620         and null $op->first->sibling)
1621     {
1622         # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1623         # with a null that's used as the common end point of the two
1624         # flows of control. For precedence purposes, ignore it.
1625         # (COND_EXPRs have these too, but we don't bother with
1626         # their associativity).
1627         return assoc_class($op->first);
1628     }
1629     return $name . ($op->flags & OPf_STACKED ? "=" : "");
1630 }
1631
1632 # Left associative operators, like `+', for which
1633 # $a + $b + $c is equivalent to ($a + $b) + $c
1634
1635 BEGIN {
1636     %left = ('multiply' => 19, 'i_multiply' => 19,
1637              'divide' => 19, 'i_divide' => 19,
1638              'modulo' => 19, 'i_modulo' => 19,
1639              'repeat' => 19,
1640              'add' => 18, 'i_add' => 18,
1641              'subtract' => 18, 'i_subtract' => 18,
1642              'concat' => 18,
1643              'left_shift' => 17, 'right_shift' => 17,
1644              'bit_and' => 13,
1645              'bit_or' => 12, 'bit_xor' => 12,
1646              'and' => 3,
1647              'or' => 2, 'xor' => 2,
1648             );
1649 }
1650
1651 sub deparse_binop_left {
1652     my $self = shift;
1653     my($op, $left, $prec) = @_;
1654     if ($left{assoc_class($op)} && $left{assoc_class($left)}
1655         and $left{assoc_class($op)} == $left{assoc_class($left)})
1656     {
1657         return $self->deparse($left, $prec - .00001);
1658     } else {
1659         return $self->deparse($left, $prec);
1660     }
1661 }
1662
1663 # Right associative operators, like `=', for which
1664 # $a = $b = $c is equivalent to $a = ($b = $c)
1665
1666 BEGIN {
1667     %right = ('pow' => 22,
1668               'sassign=' => 7, 'aassign=' => 7,
1669               'multiply=' => 7, 'i_multiply=' => 7,
1670               'divide=' => 7, 'i_divide=' => 7,
1671               'modulo=' => 7, 'i_modulo=' => 7,
1672               'repeat=' => 7,
1673               'add=' => 7, 'i_add=' => 7,
1674               'subtract=' => 7, 'i_subtract=' => 7,
1675               'concat=' => 7,
1676               'left_shift=' => 7, 'right_shift=' => 7,
1677               'bit_and=' => 7,
1678               'bit_or=' => 7, 'bit_xor=' => 7,
1679               'andassign' => 7,
1680               'orassign' => 7,
1681              );
1682 }
1683
1684 sub deparse_binop_right {
1685     my $self = shift;
1686     my($op, $right, $prec) = @_;
1687     if ($right{assoc_class($op)} && $right{assoc_class($right)}
1688         and $right{assoc_class($op)} == $right{assoc_class($right)})
1689     {
1690         return $self->deparse($right, $prec - .00001);
1691     } else {
1692         return $self->deparse($right, $prec);
1693     }
1694 }
1695
1696 sub binop {
1697     my $self = shift;
1698     my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1699     my $left = $op->first;
1700     my $right = $op->last;
1701     my $eq = "";
1702     if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1703         $eq = "=";
1704         $prec = 7;
1705     }
1706     if ($flags & SWAP_CHILDREN) {
1707         ($left, $right) = ($right, $left);
1708     }
1709     $left = $self->deparse_binop_left($op, $left, $prec);
1710     $right = $self->deparse_binop_right($op, $right, $prec);
1711     return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1712 }
1713
1714 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1715 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1716 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18,  ASSIGN) }
1717 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1718 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1719 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1720 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1721 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1722 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1723 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1724 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1725
1726 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1727 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1728 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1729 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1730 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1731
1732 sub pp_eq { binop(@_, "==", 14) }
1733 sub pp_ne { binop(@_, "!=", 14) }
1734 sub pp_lt { binop(@_, "<", 15) }
1735 sub pp_gt { binop(@_, ">", 15) }
1736 sub pp_ge { binop(@_, ">=", 15) }
1737 sub pp_le { binop(@_, "<=", 15) }
1738 sub pp_ncmp { binop(@_, "<=>", 14) }
1739 sub pp_i_eq { binop(@_, "==", 14) }
1740 sub pp_i_ne { binop(@_, "!=", 14) }
1741 sub pp_i_lt { binop(@_, "<", 15) }
1742 sub pp_i_gt { binop(@_, ">", 15) }
1743 sub pp_i_ge { binop(@_, ">=", 15) }
1744 sub pp_i_le { binop(@_, "<=", 15) }
1745 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1746
1747 sub pp_seq { binop(@_, "eq", 14) }
1748 sub pp_sne { binop(@_, "ne", 14) }
1749 sub pp_slt { binop(@_, "lt", 15) }
1750 sub pp_sgt { binop(@_, "gt", 15) }
1751 sub pp_sge { binop(@_, "ge", 15) }
1752 sub pp_sle { binop(@_, "le", 15) }
1753 sub pp_scmp { binop(@_, "cmp", 14) }
1754
1755 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1756 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1757
1758 # `.' is special because concats-of-concats are optimized to save copying
1759 # by making all but the first concat stacked. The effect is as if the
1760 # programmer had written `($a . $b) .= $c', except legal.
1761 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1762 sub real_concat {
1763     my $self = shift;
1764     my($op, $cx) = @_;
1765     my $left = $op->first;
1766     my $right = $op->last;
1767     my $eq = "";
1768     my $prec = 18;
1769     if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1770         $eq = "=";
1771         $prec = 7;
1772     }
1773     $left = $self->deparse_binop_left($op, $left, $prec);
1774     $right = $self->deparse_binop_right($op, $right, $prec);
1775     return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1776 }
1777
1778 # `x' is weird when the left arg is a list
1779 sub pp_repeat {
1780     my $self = shift;
1781     my($op, $cx) = @_;
1782     my $left = $op->first;
1783     my $right = $op->last;
1784     my $eq = "";
1785     my $prec = 19;
1786     if ($op->flags & OPf_STACKED) {
1787         $eq = "=";
1788         $prec = 7;
1789     }
1790     if (null($right)) { # list repeat; count is inside left-side ex-list
1791         my $kid = $left->first->sibling; # skip pushmark
1792         my @exprs;
1793         for (; !null($kid->sibling); $kid = $kid->sibling) {
1794             push @exprs, $self->deparse($kid, 6);
1795         }
1796         $right = $kid;
1797         $left = "(" . join(", ", @exprs). ")";
1798     } else {
1799         $left = $self->deparse_binop_left($op, $left, $prec);
1800     }
1801     $right = $self->deparse_binop_right($op, $right, $prec);
1802     return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1803 }
1804
1805 sub range {
1806     my $self = shift;
1807     my ($op, $cx, $type) = @_;
1808     my $left = $op->first;
1809     my $right = $left->sibling;
1810     $left = $self->deparse($left, 9);
1811     $right = $self->deparse($right, 9);
1812     return $self->maybe_parens("$left $type $right", $cx, 9);
1813 }
1814
1815 sub pp_flop {
1816     my $self = shift;
1817     my($op, $cx) = @_;
1818     my $flip = $op->first;
1819     my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1820     return $self->range($flip->first, $cx, $type);
1821 }
1822
1823 # one-line while/until is handled in pp_leave
1824
1825 sub logop {
1826     my $self = shift;
1827     my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1828     my $left = $op->first;
1829     my $right = $op->first->sibling;
1830     if ($cx == 0 and is_scope($right) and $blockname
1831         and $self->{'expand'} < 7)
1832     { # if ($a) {$b}
1833         $left = $self->deparse($left, 1);
1834         $right = $self->deparse($right, 0);
1835         return "$blockname ($left) {\n\t$right\n\b}\cK";
1836     } elsif ($cx == 0 and $blockname and not $self->{'parens'}
1837              and $self->{'expand'} < 7) { # $b if $a
1838         $right = $self->deparse($right, 1);
1839         $left = $self->deparse($left, 1);
1840         return "$right $blockname $left";
1841     } elsif ($cx > $lowprec and $highop) { # $a && $b
1842         $left = $self->deparse_binop_left($op, $left, $highprec);
1843         $right = $self->deparse_binop_right($op, $right, $highprec);
1844         return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1845     } else { # $a and $b
1846         $left = $self->deparse_binop_left($op, $left, $lowprec);
1847         $right = $self->deparse_binop_right($op, $right, $lowprec);
1848         return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1849     }
1850 }
1851
1852 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1853 sub pp_or  { logop(@_, "or",  2, "||", 10, "unless") }
1854
1855 # xor is syntactically a logop, but it's really a binop (contrary to
1856 # old versions of opcode.pl). Syntax is what matters here.
1857 sub pp_xor { logop(@_, "xor", 2, "",   0,  "") }
1858
1859 sub logassignop {
1860     my $self = shift;
1861     my ($op, $cx, $opname) = @_;
1862     my $left = $op->first;
1863     my $right = $op->first->sibling->first; # skip sassign
1864     $left = $self->deparse($left, 7);
1865     $right = $self->deparse($right, 7);
1866     return $self->maybe_parens("$left $opname $right", $cx, 7);
1867 }
1868
1869 sub pp_andassign { logassignop(@_, "&&=") }
1870 sub pp_orassign { logassignop(@_, "||=") }
1871
1872 sub listop {
1873     my $self = shift;
1874     my($op, $cx, $name) = @_;
1875     my(@exprs);
1876     my $parens = ($cx >= 5) || $self->{'parens'};
1877     my $kid = $op->first->sibling;
1878     return $name if null $kid;
1879     my $first = $self->deparse($kid, 6);
1880     $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1881     push @exprs, $first;
1882     $kid = $kid->sibling;
1883     for (; !null($kid); $kid = $kid->sibling) {
1884         push @exprs, $self->deparse($kid, 6);
1885     }
1886     if ($parens) {
1887         return "$name(" . join(", ", @exprs) . ")";
1888     } else {
1889         return "$name " . join(", ", @exprs);
1890     }
1891 }
1892
1893 sub pp_bless { listop(@_, "bless") }
1894 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
1895 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1896 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1897 sub pp_index { maybe_targmy(@_, \&listop, "index") }
1898 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
1899 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
1900 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1901 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
1902 sub pp_unpack { listop(@_, "unpack") }
1903 sub pp_pack { listop(@_, "pack") }
1904 sub pp_join { maybe_targmy(@_, \&listop, "join") }
1905 sub pp_splice { listop(@_, "splice") }
1906 sub pp_push { maybe_targmy(@_, \&listop, "push") }
1907 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
1908 sub pp_reverse { listop(@_, "reverse") }
1909 sub pp_warn { listop(@_, "warn") }
1910 sub pp_die { listop(@_, "die") }
1911 # Actually, return is exempt from the LLAFR (see examples in this very
1912 # module!), but for consistency's sake, ignore that fact
1913 sub pp_return { listop(@_, "return") }
1914 sub pp_open { listop(@_, "open") }
1915 sub pp_pipe_op { listop(@_, "pipe") }
1916 sub pp_tie { listop(@_, "tie") }
1917 sub pp_binmode { listop(@_, "binmode") }
1918 sub pp_dbmopen { listop(@_, "dbmopen") }
1919 sub pp_sselect { listop(@_, "select") }
1920 sub pp_select { listop(@_, "select") }
1921 sub pp_read { listop(@_, "read") }
1922 sub pp_sysopen { listop(@_, "sysopen") }
1923 sub pp_sysseek { listop(@_, "sysseek") }
1924 sub pp_sysread { listop(@_, "sysread") }
1925 sub pp_syswrite { listop(@_, "syswrite") }
1926 sub pp_send { listop(@_, "send") }
1927 sub pp_recv { listop(@_, "recv") }
1928 sub pp_seek { listop(@_, "seek") }
1929 sub pp_fcntl { listop(@_, "fcntl") }
1930 sub pp_ioctl { listop(@_, "ioctl") }
1931 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
1932 sub pp_socket { listop(@_, "socket") }
1933 sub pp_sockpair { listop(@_, "sockpair") }
1934 sub pp_bind { listop(@_, "bind") }
1935 sub pp_connect { listop(@_, "connect") }
1936 sub pp_listen { listop(@_, "listen") }
1937 sub pp_accept { listop(@_, "accept") }
1938 sub pp_shutdown { listop(@_, "shutdown") }
1939 sub pp_gsockopt { listop(@_, "getsockopt") }
1940 sub pp_ssockopt { listop(@_, "setsockopt") }
1941 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
1942 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
1943 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
1944 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
1945 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
1946 sub pp_link { maybe_targmy(@_, \&listop, "link") }
1947 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
1948 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
1949 sub pp_open_dir { listop(@_, "opendir") }
1950 sub pp_seekdir { listop(@_, "seekdir") }
1951 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
1952 sub pp_system { maybe_targmy(@_, \&listop, "system") }
1953 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
1954 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
1955 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
1956 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
1957 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
1958 sub pp_shmget { listop(@_, "shmget") }
1959 sub pp_shmctl { listop(@_, "shmctl") }
1960 sub pp_shmread { listop(@_, "shmread") }
1961 sub pp_shmwrite { listop(@_, "shmwrite") }
1962 sub pp_msgget { listop(@_, "msgget") }
1963 sub pp_msgctl { listop(@_, "msgctl") }
1964 sub pp_msgsnd { listop(@_, "msgsnd") }
1965 sub pp_msgrcv { listop(@_, "msgrcv") }
1966 sub pp_semget { listop(@_, "semget") }
1967 sub pp_semctl { listop(@_, "semctl") }
1968 sub pp_semop { listop(@_, "semop") }
1969 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1970 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1971 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1972 sub pp_gsbyname { listop(@_, "getservbyname") }
1973 sub pp_gsbyport { listop(@_, "getservbyport") }
1974 sub pp_syscall { listop(@_, "syscall") }
1975
1976 sub pp_glob {
1977     my $self = shift;
1978     my($op, $cx) = @_;
1979     my $text = $self->dq($op->first->sibling);  # skip pushmark
1980     if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1981         or $text =~ /[<>]/) {
1982         return 'glob(' . single_delim('qq', '"', $text) . ')';
1983     } else {
1984         return '<' . $text . '>';
1985     }
1986 }
1987
1988 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1989 # be a filehandle. This could probably be better fixed in the core
1990 # by moving the GV lookup into ck_truc.
1991
1992 sub pp_truncate {
1993     my $self = shift;
1994     my($op, $cx) = @_;
1995     my(@exprs);
1996     my $parens = ($cx >= 5) || $self->{'parens'};
1997     my $kid = $op->first->sibling;
1998     my $fh;
1999     if ($op->flags & OPf_SPECIAL) {
2000         # $kid is an OP_CONST
2001         $fh = $self->const_sv($kid)->PV;
2002     } else {
2003         $fh = $self->deparse($kid, 6);
2004         $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
2005     }
2006     my $len = $self->deparse($kid->sibling, 6);
2007     if ($parens) {
2008         return "truncate($fh, $len)";
2009     } else {
2010         return "truncate $fh, $len";
2011     }
2012 }
2013
2014 sub indirop {
2015     my $self = shift;
2016     my($op, $cx, $name) = @_;
2017     my($expr, @exprs);
2018     my $kid = $op->first->sibling;
2019     my $indir = "";
2020     if ($op->flags & OPf_STACKED) {
2021         $indir = $kid;
2022         $indir = $indir->first; # skip rv2gv
2023         if (is_scope($indir)) {
2024             $indir = "{" . $self->deparse($indir, 0) . "}";
2025         } else {
2026             $indir = $self->deparse($indir, 24);
2027         }
2028         $indir = $indir . " ";
2029         $kid = $kid->sibling;
2030     }
2031     for (; !null($kid); $kid = $kid->sibling) {
2032         $expr = $self->deparse($kid, 6);
2033         push @exprs, $expr;
2034     }
2035     return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
2036                                     $cx, 5);
2037 }
2038
2039 sub pp_prtf { indirop(@_, "printf") }
2040 sub pp_print { indirop(@_, "print") }
2041 sub pp_sort { indirop(@_, "sort") }
2042
2043 sub mapop {
2044     my $self = shift;
2045     my($op, $cx, $name) = @_;
2046     my($expr, @exprs);
2047     my $kid = $op->first; # this is the (map|grep)start
2048     $kid = $kid->first->sibling; # skip a pushmark
2049     my $code = $kid->first; # skip a null
2050     if (is_scope $code) {
2051         $code = "{" . $self->deparse($code, 0) . "} ";
2052     } else {
2053         $code = $self->deparse($code, 24) . ", ";
2054     }
2055     $kid = $kid->sibling;
2056     for (; !null($kid); $kid = $kid->sibling) {
2057         $expr = $self->deparse($kid, 6);
2058         push @exprs, $expr if $expr;
2059     }
2060     return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2061 }
2062
2063 sub pp_mapwhile { mapop(@_, "map") }
2064 sub pp_grepwhile { mapop(@_, "grep") }
2065
2066 sub pp_list {
2067     my $self = shift;
2068     my($op, $cx) = @_;
2069     my($expr, @exprs);
2070     my $kid = $op->first->sibling; # skip pushmark
2071     my $lop;
2072     my $local = "either"; # could be local(...) or my(...)
2073     for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2074         # This assumes that no other private flags equal 128, and that
2075         # OPs that store things other than flags in their op_private,
2076         # like OP_AELEMFAST, won't be immediate children of a list.
2077         unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
2078         {
2079             $local = ""; # or not
2080             last;
2081         }
2082         if ($lop->name =~ /^pad[ash]v$/) { # my()
2083             ($local = "", last) if $local eq "local";
2084             $local = "my";
2085         } elsif ($lop->name ne "undef") { # local()
2086             ($local = "", last) if $local eq "my";
2087             $local = "local";
2088         }
2089     }
2090     $local = "" if $local eq "either"; # no point if it's all undefs
2091     return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2092     for (; !null($kid); $kid = $kid->sibling) {
2093         if ($local) {
2094             if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2095                 $lop = $kid->first;
2096             } else {
2097                 $lop = $kid;
2098             }
2099             $self->{'avoid_local'}{$$lop}++;
2100             $expr = $self->deparse($kid, 6);
2101             delete $self->{'avoid_local'}{$$lop};
2102         } else {
2103             $expr = $self->deparse($kid, 6);
2104         }
2105         push @exprs, $expr;
2106     }
2107     if ($local) {
2108         return "$local(" . join(", ", @exprs) . ")";
2109     } else {
2110         return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2111     }
2112 }
2113
2114 sub is_ifelse_cont {
2115     my $op = shift;
2116     return ($op->name eq "null" and class($op) eq "UNOP"
2117             and $op->first->name =~ /^(and|cond_expr)$/
2118             and is_scope($op->first->first->sibling));
2119 }
2120
2121 sub pp_cond_expr {
2122     my $self = shift;
2123     my($op, $cx) = @_;
2124     my $cond = $op->first;
2125     my $true = $cond->sibling;
2126     my $false = $true->sibling;
2127     my $cuddle = $self->{'cuddle'};
2128     unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
2129             (is_scope($false) || is_ifelse_cont($false))
2130             and $self->{'expand'} < 7) {
2131         $cond = $self->deparse($cond, 8);
2132         $true = $self->deparse($true, 8);
2133         $false = $self->deparse($false, 8);
2134         return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2135     }
2136
2137     $cond = $self->deparse($cond, 1);
2138     $true = $self->deparse($true, 0);
2139     my $head = "if ($cond) {\n\t$true\n\b}";
2140     my @elsifs;
2141     while (!null($false) and is_ifelse_cont($false)) {
2142         my $newop = $false->first;
2143         my $newcond = $newop->first;
2144         my $newtrue = $newcond->sibling;
2145         $false = $newtrue->sibling; # last in chain is OP_AND => no else
2146         $newcond = $self->deparse($newcond, 1);
2147         $newtrue = $self->deparse($newtrue, 0);
2148         push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2149     }
2150     if (!null($false)) {
2151         $false = $cuddle . "else {\n\t" .
2152           $self->deparse($false, 0) . "\n\b}\cK";
2153     } else {
2154         $false = "\cK";
2155     }
2156     return $head . join($cuddle, "", @elsifs) . $false;
2157 }
2158
2159 sub loop_common {
2160     my $self = shift;
2161     my($op, $cx, $init) = @_;
2162     my $enter = $op->first;
2163     my $kid = $enter->sibling;
2164     local(@$self{qw'curstash warnings hints'})
2165                 = @$self{qw'curstash warnings hints'};
2166     my $head = "";
2167     my $bare = 0;
2168     my $body;
2169     my $cond = undef;
2170     my $out_seq = $self->{'curcop'}->cop_seq;;
2171     if ($kid->name eq "lineseq") { # bare or infinite loop
2172         if (is_state $kid->last) { # infinite
2173             $head = "for (;;) "; # shorter than while (1)
2174             $cond = "";
2175         } else {
2176             $bare = 1;
2177         }
2178         $body = $kid;
2179     } elsif ($enter->name eq "enteriter") { # foreach
2180         my $ary = $enter->first->sibling; # first was pushmark
2181         my $var = $ary->sibling;
2182         if ($enter->flags & OPf_STACKED
2183             and not null $ary->first->sibling->sibling)
2184         {
2185             $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2186               $self->deparse($ary->first->sibling->sibling, 9);
2187         } else {
2188             $ary = $self->deparse($ary, 1);
2189         }
2190         if (null $var) {
2191             if ($enter->flags & OPf_SPECIAL) { # thread special var
2192                 $var = $self->pp_threadsv($enter, 1);
2193             } else { # regular my() variable
2194                 $var = $self->pp_padsv($enter, 1);
2195                 if ($self->padname_sv($enter->targ)->IVX ==
2196                     $kid->first->first->sibling->last->cop_seq)
2197                 {
2198                     # If the scope of this variable closes at the last
2199                     # statement of the loop, it must have been
2200                     # declared here.
2201                     $var = "my " . $var;
2202                 }
2203             }
2204         } elsif ($var->name eq "rv2gv") {
2205             $var = $self->pp_rv2sv($var, 1);
2206         } elsif ($var->name eq "gv") {
2207             $var = "\$" . $self->deparse($var, 1);
2208         }
2209         $head = "foreach $var ($ary) ";
2210         $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2211     } elsif ($kid->name eq "null") { # while/until
2212         $kid = $kid->first;
2213         my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2214         $cond = $self->deparse($kid->first, 1);
2215         $head = "$name ($cond) ";
2216         $body = $kid->first->sibling;
2217     } elsif ($kid->name eq "stub") { # bare and empty
2218         return "{;}"; # {} could be a hashref
2219     }
2220     # If there isn't a continue block, then the next pointer for the loop
2221     # will point to the unstack, which is kid's penultimate child, except
2222     # in a bare loop, when it will point to the leaveloop. When neither of
2223     # these conditions hold, then the third-to-last child in the continue
2224     # block (or the last in a bare loop).
2225     my $cont_start = $enter->nextop;
2226     my $cont;
2227     if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) {
2228         if ($bare) {
2229             $cont = $body->last;
2230         } else {
2231             $cont = $body->first;
2232             while (!null($cont->sibling->sibling->sibling)) {
2233                 $cont = $cont->sibling;
2234             }
2235         }
2236         my $state = $body->first;
2237         my $cuddle = $self->{'cuddle'};
2238         my @states;
2239         for (; $$state != $$cont; $state = $state->sibling) {
2240             push @states, $state;
2241         }
2242         $body = $self->lineseq(@states);
2243         if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2244             $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2245             $cont = "\cK";
2246         } else {
2247             $cont = $cuddle . "continue {\n\t" .
2248               $self->deparse($cont, 0) . "\n\b}\cK";
2249         }
2250     } else {
2251         return "" if !defined $body;
2252         $cont = "\cK";
2253         $body = $self->deparse($body, 0);
2254     }
2255     $body .= "\n";
2256     # If we have say C<{my $x=2; sub x{$x}}>, the sub must go inside
2257     # the loop. So we insert any subs which are due here.
2258     $body .= join"", $self->seq_subs($out_seq);
2259
2260     return $head . "{\n\t" . $body . "\b}" . $cont;
2261 }
2262
2263 sub pp_leaveloop { loop_common(@_, "") }
2264
2265 sub for_loop {
2266     my $self = shift;
2267     my($op, $cx) = @_;
2268     my $init = $self->deparse($op, 1);
2269     return $self->loop_common($op->sibling, $cx, $init);
2270 }
2271
2272 sub pp_leavetry {
2273     my $self = shift;
2274     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2275 }
2276
2277 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2278 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2279
2280 sub pp_null {
2281     my $self = shift;
2282     my($op, $cx) = @_;
2283     if (class($op) eq "OP") {
2284         # old value is lost
2285         return $self->{'ex_const'} if $op->targ == OP_CONST;
2286     } elsif ($op->first->name eq "pushmark") {
2287         return $self->pp_list($op, $cx);
2288     } elsif ($op->first->name eq "enter") {
2289         return $self->pp_leave($op, $cx);
2290     } elsif ($op->targ == OP_STRINGIFY) {
2291         return $self->dquote($op, $cx);
2292     } elsif (!null($op->first->sibling) and
2293              $op->first->sibling->name eq "readline" and
2294              $op->first->sibling->flags & OPf_STACKED) {
2295         return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2296                                    . $self->deparse($op->first->sibling, 7),
2297                                    $cx, 7);
2298     } elsif (!null($op->first->sibling) and
2299              $op->first->sibling->name eq "trans" and
2300              $op->first->sibling->flags & OPf_STACKED) {
2301         return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2302                                    . $self->deparse($op->first->sibling, 20),
2303                                    $cx, 20);
2304     } else {
2305         return $self->deparse($op->first, $cx);
2306     }
2307 }
2308
2309 sub padname {
2310     my $self = shift;
2311     my $targ = shift;
2312     return $self->padname_sv($targ)->PVX;
2313 }
2314
2315 sub padany {
2316     my $self = shift;
2317     my $op = shift;
2318     return substr($self->padname($op->targ), 1); # skip $/@/%
2319 }
2320
2321 sub pp_padsv {
2322     my $self = shift;
2323     my($op, $cx) = @_;
2324     return $self->maybe_my($op, $cx, $self->padname($op->targ));
2325 }
2326
2327 sub pp_padav { pp_padsv(@_) }
2328 sub pp_padhv { pp_padsv(@_) }
2329
2330 my @threadsv_names;
2331
2332 BEGIN {
2333     @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2334                        "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2335                        "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2336                        "!", "@");
2337 }
2338
2339 sub pp_threadsv {
2340     my $self = shift;
2341     my($op, $cx) = @_;
2342     return $self->maybe_local($op, $cx, "\$" .  $threadsv_names[$op->targ]);
2343 }
2344
2345 sub gv_or_padgv {
2346     my $self = shift;
2347     my $op = shift;
2348     if (class($op) eq "PADOP") {
2349         return $self->padval($op->padix);
2350     } else { # class($op) eq "SVOP"
2351         return $op->gv;
2352     }
2353 }
2354
2355 sub pp_gvsv {
2356     my $self = shift;
2357     my($op, $cx) = @_;
2358     my $gv = $self->gv_or_padgv($op);
2359     return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2360                                  $self->gv_name($gv)));
2361 }
2362
2363 sub pp_gv {
2364     my $self = shift;
2365     my($op, $cx) = @_;
2366     my $gv = $self->gv_or_padgv($op);
2367     return $self->gv_name($gv);
2368 }
2369
2370 sub pp_aelemfast {
2371     my $self = shift;
2372     my($op, $cx) = @_;
2373     my $gv = $self->gv_or_padgv($op);
2374     return "\$" . $self->gv_name($gv) . "[" .
2375                   ($op->private + $self->{'arybase'}) . "]";
2376 }
2377
2378 sub rv2x {
2379     my $self = shift;
2380     my($op, $cx, $type) = @_;
2381     my $kid = $op->first;
2382     my $str = $self->deparse($kid, 0);
2383     return $self->stash_variable($type, $str) if is_scalar($kid);
2384     return $type ."{$str}";
2385 }
2386
2387 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2388 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2389 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2390
2391 # skip rv2av
2392 sub pp_av2arylen {
2393     my $self = shift;
2394     my($op, $cx) = @_;
2395     if ($op->first->name eq "padav") {
2396         return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2397     } else {
2398         return $self->maybe_local($op, $cx,
2399                                   $self->rv2x($op->first, $cx, '$#'));
2400     }
2401 }
2402
2403 # skip down to the old, ex-rv2cv
2404 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
2405
2406 sub pp_rv2av {
2407     my $self = shift;
2408     my($op, $cx) = @_;
2409     my $kid = $op->first;
2410     if ($kid->name eq "const") { # constant list
2411         my $av = $self->const_sv($kid);
2412         return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2413     } else {
2414         return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2415     }
2416  }
2417
2418 sub is_subscriptable {
2419     my $op = shift;
2420     if ($op->name =~ /^[ahg]elem/) {
2421         return 1;
2422     } elsif ($op->name eq "entersub") {
2423         my $kid = $op->first;
2424         return 0 unless null $kid->sibling;
2425         $kid = $kid->first;
2426         $kid = $kid->sibling until null $kid->sibling;
2427         return 0 if is_scope($kid);
2428         $kid = $kid->first;
2429         return 0 if $kid->name eq "gv";
2430         return 0 if is_scalar($kid);
2431         return is_subscriptable($kid);
2432     } else {
2433         return 0;
2434     }
2435 }
2436
2437 sub elem {
2438     my $self = shift;
2439     my ($op, $cx, $left, $right, $padname) = @_;
2440     my($array, $idx) = ($op->first, $op->first->sibling);
2441     unless ($array->name eq $padname) { # Maybe this has been fixed
2442         $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2443     }
2444     if ($array->name eq $padname) {
2445         $array = $self->padany($array);
2446     } elsif (is_scope($array)) { # ${expr}[0]
2447         $array = "{" . $self->deparse($array, 0) . "}";
2448     } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2449         $array = $self->deparse($array, 24);
2450     } else {
2451         # $x[20][3]{hi} or expr->[20]
2452         my $arrow = is_subscriptable($array) ? "" : "->";
2453         return $self->deparse($array, 24) . $arrow .
2454             $left . $self->deparse($idx, 1) . $right;
2455     }
2456     $idx = $self->deparse($idx, 1);
2457
2458     # Outer parens in an array index will confuse perl
2459     # if we're interpolating in a regular expression, i.e.
2460     # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2461     #
2462     # If $self->{parens}, then an initial '(' will
2463     # definitely be paired with a final ')'. If
2464     # !$self->{parens}, the misleading parens won't
2465     # have been added in the first place.
2466     #
2467     # [You might think that we could get "(...)...(...)"
2468     # where the initial and final parens do not match
2469     # each other. But we can't, because the above would
2470     # only happen if there's an infix binop between the
2471     # two pairs of parens, and *that* means that the whole
2472     # expression would be parenthesized as well.]
2473     #
2474     $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2475
2476     return "\$" . $array . $left . $idx . $right;
2477 }
2478
2479 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2480 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2481
2482 sub pp_gelem {
2483     my $self = shift;
2484     my($op, $cx) = @_;
2485     my($glob, $part) = ($op->first, $op->last);
2486     $glob = $glob->first; # skip rv2gv
2487     $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2488     my $scope = is_scope($glob);
2489     $glob = $self->deparse($glob, 0);
2490     $part = $self->deparse($part, 1);
2491     return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2492 }
2493
2494 sub slice {
2495     my $self = shift;
2496     my ($op, $cx, $left, $right, $regname, $padname) = @_;
2497     my $last;
2498     my(@elems, $kid, $array, $list);
2499     if (class($op) eq "LISTOP") {
2500         $last = $op->last;
2501     } else { # ex-hslice inside delete()
2502         for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2503         $last = $kid;
2504     }
2505     $array = $last;
2506     $array = $array->first
2507         if $array->name eq $regname or $array->name eq "null";
2508     if (is_scope($array)) {
2509         $array = "{" . $self->deparse($array, 0) . "}";
2510     } elsif ($array->name eq $padname) {
2511         $array = $self->padany($array);
2512     } else {
2513         $array = $self->deparse($array, 24);
2514     }
2515     $kid = $op->first->sibling; # skip pushmark
2516     if ($kid->name eq "list") {
2517         $kid = $kid->first->sibling; # skip list, pushmark
2518         for (; !null $kid; $kid = $kid->sibling) {
2519             push @elems, $self->deparse($kid, 6);
2520         }
2521         $list = join(", ", @elems);
2522     } else {
2523         $list = $self->deparse($kid, 1);
2524     }
2525     return "\@" . $array . $left . $list . $right;
2526 }
2527
2528 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2529 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2530
2531 sub pp_lslice {
2532     my $self = shift;
2533     my($op, $cx) = @_;
2534     my $idx = $op->first;
2535     my $list = $op->last;
2536     my(@elems, $kid);
2537     $list = $self->deparse($list, 1);
2538     $idx = $self->deparse($idx, 1);
2539     return "($list)" . "[$idx]";
2540 }
2541
2542 sub want_scalar {
2543     my $op = shift;
2544     return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2545 }
2546
2547 sub want_list {
2548     my $op = shift;
2549     return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2550 }
2551
2552 sub method {
2553     my $self = shift;
2554     my($op, $cx) = @_;
2555     my $kid = $op->first->sibling; # skip pushmark
2556     my($meth, $obj, @exprs);
2557     if ($kid->name eq "list" and want_list $kid) {
2558         # When an indirect object isn't a bareword but the args are in
2559         # parens, the parens aren't part of the method syntax (the LLAFR
2560         # doesn't apply), but they make a list with OPf_PARENS set that
2561         # doesn't get flattened by the append_elem that adds the method,
2562         # making a (object, arg1, arg2, ...) list where the object
2563         # usually is. This can be distinguished from
2564         # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2565         # object) because in the later the list is in scalar context
2566         # as the left side of -> always is, while in the former
2567         # the list is in list context as method arguments always are.
2568         # (Good thing there aren't method prototypes!)
2569         $meth = $kid->sibling;
2570         $kid = $kid->first->sibling; # skip pushmark
2571         $obj = $kid;
2572         $kid = $kid->sibling;
2573         for (; not null $kid; $kid = $kid->sibling) {
2574             push @exprs, $self->deparse($kid, 6);
2575         }
2576     } else {
2577         $obj = $kid;
2578         $kid = $kid->sibling;
2579         for (; not null $kid->sibling; $kid = $kid->sibling) {
2580             push @exprs, $self->deparse($kid, 6);
2581         }
2582         $meth = $kid;
2583     }
2584     $obj = $self->deparse($obj, 24);
2585     if ($meth->name eq "method_named") {
2586         $meth = $self->const_sv($meth)->PV;
2587     } else {
2588         $meth = $meth->first;
2589         if ($meth->name eq "const") {
2590             # As of 5.005_58, this case is probably obsoleted by the
2591             # method_named case above
2592             $meth = $self->const_sv($meth)->PV; # needs to be bare
2593         } else {
2594             $meth = $self->deparse($meth, 1);
2595         }
2596     }
2597     my $args = join(", ", @exprs);
2598     $kid = $obj . "->" . $meth;
2599     if ($args) {
2600         return $kid . "(" . $args . ")"; # parens mandatory
2601     } else {
2602         return $kid;
2603     }
2604 }
2605
2606 # returns "&" if the prototype doesn't match the args,
2607 # or ("", $args_after_prototype_demunging) if it does.
2608 sub check_proto {
2609     my $self = shift;
2610     my($proto, @args) = @_;
2611     my($arg, $real);
2612     my $doneok = 0;
2613     my @reals;
2614     # An unbackslashed @ or % gobbles up the rest of the args
2615     $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2616     while ($proto) {
2617         $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2618         my $chr = $1;
2619         if ($chr eq "") {
2620             return "&" if @args;
2621         } elsif ($chr eq ";") {
2622             $doneok = 1;
2623         } elsif ($chr eq "@" or $chr eq "%") {
2624             push @reals, map($self->deparse($_, 6), @args);
2625             @args = ();
2626         } else {
2627             $arg = shift @args;
2628             last unless $arg;
2629             if ($chr eq "\$") {
2630                 if (want_scalar $arg) {
2631                     push @reals, $self->deparse($arg, 6);
2632                 } else {
2633                     return "&";
2634                 }
2635             } elsif ($chr eq "&") {
2636                 if ($arg->name =~ /^(s?refgen|undef)$/) {
2637                     push @reals, $self->deparse($arg, 6);
2638                 } else {
2639                     return "&";
2640                 }
2641             } elsif ($chr eq "*") {
2642                 if ($arg->name =~ /^s?refgen$/
2643                     and $arg->first->first->name eq "rv2gv")
2644                   {
2645                       $real = $arg->first->first; # skip refgen, null
2646                       if ($real->first->name eq "gv") {
2647                           push @reals, $self->deparse($real, 6);
2648                       } else {
2649                           push @reals, $self->deparse($real->first, 6);
2650                       }
2651                   } else {
2652                       return "&";
2653                   }
2654             } elsif (substr($chr, 0, 1) eq "\\") {
2655                 $chr = substr($chr, 1);
2656                 if ($arg->name =~ /^s?refgen$/ and
2657                     !null($real = $arg->first) and
2658                     ($chr eq "\$" && is_scalar($real->first)
2659                      or ($chr eq "\@"
2660                          && $real->first->sibling->name
2661                          =~ /^(rv2|pad)av$/)
2662                      or ($chr eq "%"
2663                          && $real->first->sibling->name
2664                          =~ /^(rv2|pad)hv$/)
2665                      #or ($chr eq "&" # This doesn't work
2666                      #   && $real->first->name eq "rv2cv")
2667                      or ($chr eq "*"
2668                          && $real->first->name eq "rv2gv")))
2669                   {
2670                       push @reals, $self->deparse($real, 6);
2671                   } else {
2672                       return "&";
2673                   }
2674             }
2675        }
2676     }
2677     return "&" if $proto and !$doneok; # too few args and no `;'
2678     return "&" if @args;               # too many args
2679     return ("", join ", ", @reals);
2680 }
2681
2682 sub pp_entersub {
2683     my $self = shift;
2684     my($op, $cx) = @_;
2685     return $self->method($op, $cx) unless null $op->first->sibling;
2686     my $prefix = "";
2687     my $amper = "";
2688     my($kid, @exprs);
2689     if ($op->flags & OPf_SPECIAL) {
2690         $prefix = "do ";
2691     } elsif ($op->private & OPpENTERSUB_AMPER) {
2692         $amper = "&";
2693     }
2694     $kid = $op->first;
2695     $kid = $kid->first->sibling; # skip ex-list, pushmark
2696     for (; not null $kid->sibling; $kid = $kid->sibling) {
2697         push @exprs, $kid;
2698     }
2699     my $simple = 0;
2700     my $proto = undef;
2701     if (is_scope($kid)) {
2702         $amper = "&";
2703         $kid = "{" . $self->deparse($kid, 0) . "}";
2704     } elsif ($kid->first->name eq "gv") {
2705         my $gv = $self->gv_or_padgv($kid->first);
2706         if (class($gv->CV) ne "SPECIAL") {
2707             $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2708         }
2709         $simple = 1; # only calls of named functions can be prototyped
2710         $kid = $self->deparse($kid, 24);
2711     } elsif (is_scalar $kid->first) {
2712         $amper = "&";
2713         $kid = $self->deparse($kid, 24);
2714     } else {
2715         $prefix = "";
2716         my $arrow = is_subscriptable($kid->first) ? "" : "->";
2717         $kid = $self->deparse($kid, 24) . $arrow;
2718     }
2719
2720     # Doesn't matter how many prototypes there are, if
2721     # they haven't happened yet!
2722     my $declared = exists $self->{'subs_declared'}{$kid};
2723
2724     my $args;
2725     if ($declared and defined $proto and not $amper) {
2726         ($amper, $args) = $self->check_proto($proto, @exprs);
2727         if ($amper eq "&") {
2728             $args = join(", ", map($self->deparse($_, 6), @exprs));
2729         }
2730     } else {
2731         $args = join(", ", map($self->deparse($_, 6), @exprs));
2732     }
2733     if ($prefix or $amper) {
2734         if ($op->flags & OPf_STACKED) {
2735             return $prefix . $amper . $kid . "(" . $args . ")";
2736         } else {
2737             return $prefix . $amper. $kid;
2738         }
2739     } else {
2740         # glob() invocations can be translated into calls of
2741         # CORE::GLOBAL::glob with an second parameter, a number.
2742         # Reverse this.
2743         if ($kid eq "CORE::GLOBAL::glob") {
2744             $kid = "glob";
2745             $args =~ s/\s*,[^,]+$//;
2746         }
2747
2748         # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
2749         # so it must have been translated from a keyword call. Translate
2750         # it back.
2751         $kid =~ s/^CORE::GLOBAL:://;
2752
2753         if (!$declared) {
2754             return "$kid(" . $args . ")";
2755         } elsif (defined $proto and $proto eq "") {
2756             return $kid;
2757         } elsif (defined $proto and $proto eq "\$") {
2758             return $self->maybe_parens_func($kid, $args, $cx, 16);
2759         } elsif (defined($proto) && $proto or $simple) {
2760             return $self->maybe_parens_func($kid, $args, $cx, 5);
2761         } else {
2762             return "$kid(" . $args . ")";
2763         }
2764     }
2765 }
2766
2767 sub pp_enterwrite { unop(@_, "write") }
2768
2769 # escape things that cause interpolation in double quotes,
2770 # but not character escapes
2771 sub uninterp {
2772     my($str) = @_;
2773     $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2774     return $str;
2775 }
2776
2777 # the same, but treat $|, $), and $ at the end of the string differently
2778 sub re_uninterp {
2779     my($str) = @_;
2780     $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2781     $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2782     return $str;
2783 }
2784
2785 # character escapes, but not delimiters that might need to be escaped
2786 sub escape_str { # ASCII, UTF8
2787     my($str) = @_;
2788     $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
2789     $str =~ s/\a/\\a/g;
2790 #    $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2791     $str =~ s/\t/\\t/g;
2792     $str =~ s/\n/\\n/g;
2793     $str =~ s/\e/\\e/g;
2794     $str =~ s/\f/\\f/g;
2795     $str =~ s/\r/\\r/g;
2796     $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2797     $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2798     return $str;
2799 }
2800
2801 # Don't do this for regexen
2802 sub unback {
2803     my($str) = @_;
2804     $str =~ s/\\/\\\\/g;
2805     return $str;
2806 }
2807
2808 # Remove backslashes which precede literal control characters,
2809 # to avoid creating ambiguity when we escape the latter.
2810 sub re_unback {
2811     my($str) = @_;
2812
2813     # the insane complexity here is due to the behaviour of "\c\"
2814     $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
2815     return $str;
2816 }
2817
2818 sub balanced_delim {
2819     my($str) = @_;
2820     my @str = split //, $str;
2821     my($ar, $open, $close, $fail, $c, $cnt);
2822     for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2823         ($open, $close) = @$ar;
2824         $fail = 0; $cnt = 0;
2825         for $c (@str) {
2826             if ($c eq $open) {
2827                 $cnt++;
2828             } elsif ($c eq $close) {
2829                 $cnt--;
2830                 if ($cnt < 0) {
2831                     # qq()() isn't ")("
2832                     $fail = 1;
2833                     last;
2834                 }
2835             }
2836         }
2837         $fail = 1 if $cnt != 0;
2838         return ($open, "$open$str$close") if not $fail;
2839     }
2840     return ("", $str);
2841 }
2842
2843 sub single_delim {
2844     my($q, $default, $str) = @_;
2845     return "$default$str$default" if $default and index($str, $default) == -1;
2846     my($succeed, $delim);
2847     ($succeed, $str) = balanced_delim($str);
2848     return "$q$str" if $succeed;
2849     for $delim ('/', '"', '#') {
2850         return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2851     }
2852     if ($default) {
2853         $str =~ s/$default/\\$default/g;
2854         return "$default$str$default";
2855     } else {
2856         $str =~ s[/][\\/]g;
2857         return "$q/$str/";
2858     }
2859 }
2860
2861 sub const {
2862     my $sv = shift;
2863     if (class($sv) eq "SPECIAL") {
2864         return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2865     } elsif (class($sv) eq "NULL") {
2866        return 'undef';
2867     } elsif ($sv->FLAGS & SVf_IOK) {
2868         return $sv->int_value;
2869     } elsif ($sv->FLAGS & SVf_NOK) {
2870         return $sv->NV;
2871     } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
2872         return "\\(" . const($sv->RV) . ")"; # constant folded
2873     } else {
2874         my $str = $sv->PV;
2875         if ($str =~ /[^ -~]/) { # ASCII for non-printing
2876             return single_delim("qq", '"', uninterp escape_str unback $str);
2877         } else {
2878             return single_delim("q", "'", unback $str);
2879         }
2880     }
2881 }
2882
2883 sub const_sv {
2884     my $self = shift;
2885     my $op = shift;
2886     my $sv = $op->sv;
2887     # the constant could be in the pad (under useithreads)
2888     $sv = $self->padval($op->targ) unless $$sv;
2889     return $sv;
2890 }
2891
2892 sub pp_const {
2893     my $self = shift;
2894     my($op, $cx) = @_;
2895     if ($op->private & OPpCONST_ARYBASE) {
2896         return '$[';
2897     }
2898 #    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2899 #       return $self->const_sv($op)->PV;
2900 #    }
2901     my $sv = $self->const_sv($op);
2902 #    return const($sv);
2903     my $c = const $sv;
2904     return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
2905 }
2906
2907 sub dq {
2908     my $self = shift;
2909     my $op = shift;
2910     my $type = $op->name;
2911     if ($type eq "const") {
2912         return '$[' if $op->private & OPpCONST_ARYBASE;
2913         return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
2914     } elsif ($type eq "concat") {
2915         my $first = $self->dq($op->first);
2916         my $last  = $self->dq($op->last);
2917         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2918         if ($last =~ /^[A-Z\\\^\[\]_?]/) {
2919             $first =~ s/([\$@])\^$/${1}{^}/;  # "${^}W" etc
2920         }
2921         elsif ($last =~ /^[{\[\w]/) {
2922             $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2923         }
2924         return $first . $last;
2925     } elsif ($type eq "uc") {
2926         return '\U' . $self->dq($op->first->sibling) . '\E';
2927     } elsif ($type eq "lc") {
2928         return '\L' . $self->dq($op->first->sibling) . '\E';
2929     } elsif ($type eq "ucfirst") {
2930         return '\u' . $self->dq($op->first->sibling);
2931     } elsif ($type eq "lcfirst") {
2932         return '\l' . $self->dq($op->first->sibling);
2933     } elsif ($type eq "quotemeta") {
2934         return '\Q' . $self->dq($op->first->sibling) . '\E';
2935     } elsif ($type eq "join") {
2936         return $self->deparse($op->last, 26); # was join($", @ary)
2937     } else {
2938         return $self->deparse($op, 26);
2939     }
2940 }
2941
2942 sub pp_backtick {
2943     my $self = shift;
2944     my($op, $cx) = @_;
2945     # skip pushmark
2946     return single_delim("qx", '`', $self->dq($op->first->sibling));
2947 }
2948
2949 sub dquote {
2950     my $self = shift;
2951     my($op, $cx) = @_;
2952     my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2953     return $self->deparse($kid, $cx) if $self->{'unquote'};
2954     $self->maybe_targmy($kid, $cx,
2955                         sub {single_delim("qq", '"', $self->dq($_[1]))});
2956 }
2957
2958 # OP_STRINGIFY is a listop, but it only ever has one arg
2959 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2960
2961 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2962 # note that tr(from)/to/ is OK, but not tr/from/(to)
2963 sub double_delim {
2964     my($from, $to) = @_;
2965     my($succeed, $delim);
2966     if ($from !~ m[/] and $to !~ m[/]) {
2967         return "/$from/$to/";
2968     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2969         if (($succeed, $to) = balanced_delim($to) and $succeed) {
2970             return "$from$to";
2971         } else {
2972             for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2973                 return "$from$delim$to$delim" if index($to, $delim) == -1;
2974             }
2975             $to =~ s[/][\\/]g;
2976             return "$from/$to/";
2977         }
2978     } else {
2979         for $delim ('/', '"', '#') { # note no '
2980             return "$delim$from$delim$to$delim"
2981                 if index($to . $from, $delim) == -1;
2982         }
2983         $from =~ s[/][\\/]g;
2984         $to =~ s[/][\\/]g;
2985         return "/$from/$to/";
2986     }
2987 }
2988
2989 sub pchr { # ASCII
2990     my($n) = @_;
2991     if ($n == ord '\\') {
2992         return '\\\\';
2993     } elsif ($n >= ord(' ') and $n <= ord('~')) {
2994         return chr($n);
2995     } elsif ($n == ord "\a") {
2996         return '\\a';
2997     } elsif ($n == ord "\b") {
2998         return '\\b';
2999     } elsif ($n == ord "\t") {
3000         return '\\t';
3001     } elsif ($n == ord "\n") {
3002         return '\\n';
3003     } elsif ($n == ord "\e") {
3004         return '\\e';
3005     } elsif ($n == ord "\f") {
3006         return '\\f';
3007     } elsif ($n == ord "\r") {
3008         return '\\r';
3009     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3010         return '\\c' . chr(ord("@") + $n);
3011     } else {
3012 #       return '\x' . sprintf("%02x", $n);
3013         return '\\' . sprintf("%03o", $n);
3014     }
3015 }
3016
3017 sub collapse {
3018     my(@chars) = @_;
3019     my($str, $c, $tr) = ("");
3020     for ($c = 0; $c < @chars; $c++) {
3021         $tr = $chars[$c];
3022         $str .= pchr($tr);
3023         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3024             $chars[$c + 2] == $tr + 2)
3025         {
3026             for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3027               {}
3028             $str .= "-";
3029             $str .= pchr($chars[$c]);
3030         }
3031     }
3032     return $str;
3033 }
3034
3035 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
3036 # and backslashes.
3037
3038 sub tr_decode_byte {
3039     my($table, $flags) = @_;
3040     my(@table) = unpack("s256", $table);
3041     my($c, $tr, @from, @to, @delfrom, $delhyphen);
3042     if ($table[ord "-"] != -1 and
3043         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3044     {
3045         $tr = $table[ord "-"];
3046         $table[ord "-"] = -1;
3047         if ($tr >= 0) {
3048             @from = ord("-");
3049             @to = $tr;
3050         } else { # -2 ==> delete
3051             $delhyphen = 1;
3052         }
3053     }
3054     for ($c = 0; $c < 256; $c++) {
3055         $tr = $table[$c];
3056         if ($tr >= 0) {
3057             push @from, $c; push @to, $tr;
3058         } elsif ($tr == -2) {
3059             push @delfrom, $c;
3060         }
3061     }
3062     @from = (@from, @delfrom);
3063     if ($flags & OPpTRANS_COMPLEMENT) {
3064         my @newfrom = ();
3065         my %from;
3066         @from{@from} = (1) x @from;
3067         for ($c = 0; $c < 256; $c++) {
3068             push @newfrom, $c unless $from{$c};
3069         }
3070         @from = @newfrom;
3071     }
3072     unless ($flags & OPpTRANS_DELETE || !@to) {
3073         pop @to while $#to and $to[$#to] == $to[$#to -1];
3074     }
3075     my($from, $to);
3076     $from = collapse(@from);
3077     $to = collapse(@to);
3078     $from .= "-" if $delhyphen;
3079     return ($from, $to);
3080 }
3081
3082 sub tr_chr {
3083     my $x = shift;
3084     if ($x == ord "-") {
3085         return "\\-";
3086     } else {
3087         return chr $x;
3088     }
3089 }
3090
3091 # XXX This doesn't yet handle all cases correctly either
3092
3093 sub tr_decode_utf8 {
3094     my($swash_hv, $flags) = @_;
3095     my %swash = $swash_hv->ARRAY;
3096     my $final = undef;
3097     $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3098     my $none = $swash{"NONE"}->IV;
3099     my $extra = $none + 1;
3100     my(@from, @delfrom, @to);
3101     my $line;
3102     foreach $line (split /\n/, $swash{'LIST'}->PV) {
3103         my($min, $max, $result) = split(/\t/, $line);
3104         $min = hex $min;
3105         if (length $max) {
3106             $max = hex $max;
3107         } else {
3108             $max = $min;
3109         }
3110         $result = hex $result;
3111         if ($result == $extra) {
3112             push @delfrom, [$min, $max];
3113         } else {
3114             push @from, [$min, $max];
3115             push @to, [$result, $result + $max - $min];
3116         }
3117     }
3118     for my $i (0 .. $#from) {
3119         if ($from[$i][0] == ord '-') {
3120             unshift @from, splice(@from, $i, 1);
3121             unshift @to, splice(@to, $i, 1);
3122             last;
3123         } elsif ($from[$i][1] == ord '-') {
3124             $from[$i][1]--;
3125             $to[$i][1]--;
3126             unshift @from, ord '-';
3127             unshift @to, ord '-';
3128             last;
3129         }
3130     }
3131     for my $i (0 .. $#delfrom) {
3132         if ($delfrom[$i][0] == ord '-') {
3133             push @delfrom, splice(@delfrom, $i, 1);
3134             last;
3135         } elsif ($delfrom[$i][1] == ord '-') {
3136             $delfrom[$i][1]--;
3137             push @delfrom, ord '-';
3138             last;
3139         }
3140     }
3141     if (defined $final and $to[$#to][1] != $final) {
3142         push @to, [$final, $final];
3143     }
3144     push @from, @delfrom;
3145     if ($flags & OPpTRANS_COMPLEMENT) {
3146         my @newfrom;
3147         my $next = 0;
3148         for my $i (0 .. $#from) {
3149             push @newfrom, [$next, $from[$i][0] - 1];
3150             $next = $from[$i][1] + 1;
3151         }
3152         @from = ();
3153         for my $range (@newfrom) {
3154             if ($range->[0] <= $range->[1]) {
3155                 push @from, $range;
3156             }
3157         }
3158     }
3159     my($from, $to, $diff);
3160     for my $chunk (@from) {
3161         $diff = $chunk->[1] - $chunk->[0];
3162         if ($diff > 1) {
3163             $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3164         } elsif ($diff == 1) {
3165             $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3166         } else {
3167             $from .= tr_chr($chunk->[0]);
3168         }
3169     }
3170     for my $chunk (@to) {
3171         $diff = $chunk->[1] - $chunk->[0];
3172         if ($diff > 1) {
3173             $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3174         } elsif ($diff == 1) {
3175             $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3176         } else {
3177             $to .= tr_chr($chunk->[0]);
3178         }
3179     }
3180     #$final = sprintf("%04x", $final) if defined $final;
3181     #$none = sprintf("%04x", $none) if defined $none;
3182     #$extra = sprintf("%04x", $extra) if defined $extra;
3183     #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3184     #print STDERR $swash{'LIST'}->PV;
3185     return (escape_str($from), escape_str($to));
3186 }
3187
3188 sub pp_trans {
3189     my $self = shift;
3190     my($op, $cx) = @_;
3191     my($from, $to);
3192     if (class($op) eq "PVOP") {
3193         ($from, $to) = tr_decode_byte($op->pv, $op->private);
3194     } else { # class($op) eq "SVOP"
3195         ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3196     }
3197     my $flags = "";
3198     $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3199     $flags .= "d" if $op->private & OPpTRANS_DELETE;
3200     $to = "" if $from eq $to and $flags eq "";
3201     $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3202     return "tr" . double_delim($from, $to) . $flags;
3203 }
3204
3205 # Like dq(), but different
3206 sub re_dq {
3207     my $self = shift;
3208     my $op = shift;
3209     my $type = $op->name;
3210     if ($type eq "const") {
3211         return '$[' if $op->private & OPpCONST_ARYBASE;
3212         return re_uninterp(escape_str(re_unback($self->const_sv($op)->as_string)));
3213     } elsif ($type eq "concat") {
3214         my $first = $self->re_dq($op->first);
3215         my $last  = $self->re_dq($op->last);
3216         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3217         if ($last =~ /^[A-Z\\\^\[\]_?]/) {
3218             $first =~ s/([\$@])\^$/${1}{^}/;
3219         }
3220         elsif ($last =~ /^[{\[\w]/) {
3221             $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
3222         }
3223         return $first . $last;
3224     } elsif ($type eq "uc") {
3225         return '\U' . $self->re_dq($op->first->sibling) . '\E';
3226     } elsif ($type eq "lc") {
3227         return '\L' . $self->re_dq($op->first->sibling) . '\E';
3228     } elsif ($type eq "ucfirst") {
3229         return '\u' . $self->re_dq($op->first->sibling);
3230     } elsif ($type eq "lcfirst") {
3231         return '\l' . $self->re_dq($op->first->sibling);
3232     } elsif ($type eq "quotemeta") {
3233         return '\Q' . $self->re_dq($op->first->sibling) . '\E';
3234     } elsif ($type eq "join") {
3235         return $self->deparse($op->last, 26); # was join($", @ary)
3236     } else {
3237         return $self->deparse($op, 26);
3238     }
3239 }
3240
3241 sub pp_regcomp {
3242     my $self = shift;
3243     my($op, $cx) = @_;
3244     my $kid = $op->first;
3245     $kid = $kid->first if $kid->name eq "regcmaybe";
3246     $kid = $kid->first if $kid->name eq "regcreset";
3247     return $self->re_dq($kid);
3248 }
3249
3250 # osmic acid -- see osmium tetroxide
3251
3252 my %matchwords;
3253 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3254     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3255     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3256
3257 sub matchop {
3258     my $self = shift;
3259     my($op, $cx, $name, $delim) = @_;
3260     my $kid = $op->first;
3261     my ($binop, $var, $re) = ("", "", "");
3262     if ($op->flags & OPf_STACKED) {
3263         $binop = 1;
3264         $var = $self->deparse($kid, 20);
3265         $kid = $kid->sibling;
3266     }
3267     if (null $kid) {
3268         $re = re_uninterp(escape_str(re_unback($op->precomp)));
3269     } else {
3270         $re = $self->deparse($kid, 1);
3271     }
3272     my $flags = "";
3273     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3274     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3275     $flags .= "i" if $op->pmflags & PMf_FOLD;
3276     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3277     $flags .= "o" if $op->pmflags & PMf_KEEP;
3278     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3279     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3280     $flags = $matchwords{$flags} if $matchwords{$flags};
3281     if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3282         $re =~ s/\?/\\?/g;
3283         $re = "?$re?";
3284     } else {
3285         $re = single_delim($name, $delim, $re);
3286     }
3287     $re = $re . $flags;
3288     if ($binop) {
3289         return $self->maybe_parens("$var =~ $re", $cx, 20);
3290     } else {
3291         return $re;
3292     }
3293 }
3294
3295 sub pp_match { matchop(@_, "m", "/") }
3296 sub pp_pushre { matchop(@_, "m", "/") }
3297 sub pp_qr { matchop(@_, "qr", "") }
3298
3299 sub pp_split {
3300     my $self = shift;
3301     my($op, $cx) = @_;
3302     my($kid, @exprs, $ary, $expr);
3303     $kid = $op->first;
3304     if ($ {$kid->pmreplroot}) {
3305         $ary = '@' . $self->gv_name($kid->pmreplroot);
3306     }
3307     for (; !null($kid); $kid = $kid->sibling) {
3308         push @exprs, $self->deparse($kid, 6);
3309     }
3310
3311     # handle special case of split(), and split(" ") that compiles to /\s+/
3312     $kid = $op->first;
3313     if ($kid->flags & OPf_SPECIAL
3314         && $exprs[0] eq '/\\s+/'
3315         && $kid->pmflags & PMf_SKIPWHITE ) {
3316             $exprs[0] = '" "';
3317     }
3318
3319     $expr = "split(" . join(", ", @exprs) . ")";
3320     if ($ary) {
3321         return $self->maybe_parens("$ary = $expr", $cx, 7);
3322     } else {
3323         return $expr;
3324     }
3325 }
3326
3327 # oxime -- any of various compounds obtained chiefly by the action of
3328 # hydroxylamine on aldehydes and ketones and characterized by the
3329 # bivalent grouping C=NOH [Webster's Tenth]
3330
3331 my %substwords;
3332 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3333     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3334     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3335     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3336
3337 sub pp_subst {
3338     my $self = shift;
3339     my($op, $cx) = @_;
3340     my $kid = $op->first;
3341     my($binop, $var, $re, $repl) = ("", "", "", "");
3342     if ($op->flags & OPf_STACKED) {
3343         $binop = 1;
3344         $var = $self->deparse($kid, 20);
3345         $kid = $kid->sibling;
3346     }
3347     my $flags = "";
3348     if (null($op->pmreplroot)) {
3349         $repl = $self->dq($kid);
3350         $kid = $kid->sibling;
3351     } else {
3352         $repl = $op->pmreplroot->first; # skip substcont
3353         while ($repl->name eq "entereval") {
3354             $repl = $repl->first;
3355             $flags .= "e";
3356         }
3357         if ($op->pmflags & PMf_EVAL) {
3358             $repl = $self->deparse($repl, 0);
3359         } else {
3360             $repl = $self->dq($repl);
3361         }
3362     }
3363     if (null $kid) {
3364         $re = re_uninterp(escape_str(re_unback($op->precomp)));
3365     } else {
3366         $re = $self->deparse($kid, 1);
3367     }
3368     $flags .= "e" if $op->pmflags & PMf_EVAL;
3369     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3370     $flags .= "i" if $op->pmflags & PMf_FOLD;
3371     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3372     $flags .= "o" if $op->pmflags & PMf_KEEP;
3373     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3374     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3375     $flags = $substwords{$flags} if $substwords{$flags};
3376     if ($binop) {
3377         return $self->maybe_parens("$var =~ s"
3378                                    . double_delim($re, $repl) . $flags,
3379                                    $cx, 20);
3380     } else {
3381         return "s". double_delim($re, $repl) . $flags;
3382     }
3383 }
3384
3385 1;
3386 __END__
3387
3388 =head1 NAME
3389
3390 B::Deparse - Perl compiler backend to produce perl code
3391
3392 =head1 SYNOPSIS
3393
3394 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3395         [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3396
3397 =head1 DESCRIPTION
3398
3399 B::Deparse is a backend module for the Perl compiler that generates
3400 perl source code, based on the internal compiled structure that perl
3401 itself creates after parsing a program. The output of B::Deparse won't
3402 be exactly the same as the original source, since perl doesn't keep
3403 track of comments or whitespace, and there isn't a one-to-one
3404 correspondence between perl's syntactical constructions and their
3405 compiled form, but it will often be close. When you use the B<-p>
3406 option, the output also includes parentheses even when they are not
3407 required by precedence, which can make it easy to see if perl is
3408 parsing your expressions the way you intended.
3409
3410 Please note that this module is mainly new and untested code and is
3411 still under development, so it may change in the future.
3412
3413 =head1 OPTIONS
3414
3415 As with all compiler backend options, these must follow directly after
3416 the '-MO=Deparse', separated by a comma but not any white space.
3417
3418 =over 4
3419
3420 =item B<-l>
3421
3422 Add '#line' declarations to the output based on the line and file
3423 locations of the original code.
3424
3425 =item B<-p>
3426
3427 Print extra parentheses. Without this option, B::Deparse includes
3428 parentheses in its output only when they are needed, based on the
3429 structure of your program. With B<-p>, it uses parentheses (almost)
3430 whenever they would be legal. This can be useful if you are used to
3431 LISP, or if you want to see how perl parses your input. If you say
3432
3433     if ($var & 0x7f == 65) {print "Gimme an A!"}
3434     print ($which ? $a : $b), "\n";
3435     $name = $ENV{USER} or "Bob";
3436
3437 C<B::Deparse,-p> will print
3438
3439     if (($var & 0)) {
3440         print('Gimme an A!')
3441     };
3442     (print(($which ? $a : $b)), '???');
3443     (($name = $ENV{'USER'}) or '???')
3444
3445 which probably isn't what you intended (the C<'???'> is a sign that
3446 perl optimized away a constant value).
3447
3448 =item B<-q>
3449
3450 Expand double-quoted strings into the corresponding combinations of
3451 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3452 instance, print
3453
3454     print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3455
3456 as
3457
3458     print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3459           . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3460
3461 Note that the expanded form represents the way perl handles such
3462 constructions internally -- this option actually turns off the reverse
3463 translation that B::Deparse usually does. On the other hand, note that
3464 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3465 of $y into a string before doing the assignment.
3466
3467 =item B<-f>I<FILE>
3468
3469 Normally, B::Deparse deparses the main code of a program, and all the subs
3470 defined in the same file. To include subs defined in other files, pass the
3471 B<-f> option with the filename. You can pass the B<-f> option several times, to
3472 include more than one secondary file.  (Most of the time you don't want to
3473 use it at all.)  You can also use this option to include subs which are
3474 defined in the scope of a B<#line> directive with two parameters.
3475
3476 =item B<-s>I<LETTERS>
3477
3478 Tweak the style of B::Deparse's output. The letters should follow
3479 directly after the 's', with no space or punctuation. The following
3480 options are available:
3481
3482 =over 4
3483
3484 =item B<C>
3485
3486 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3487
3488     if (...) {
3489          ...
3490     } else {
3491          ...
3492     }
3493
3494 instead of
3495
3496     if (...) {
3497          ...
3498     }
3499     else {
3500          ...
3501     }
3502
3503 The default is not to cuddle.
3504
3505 =item B<i>I<NUMBER>
3506
3507 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3508
3509 =item B<T>
3510
3511 Use tabs for each 8 columns of indent. The default is to use only spaces.
3512 For instance, if the style options are B<-si4T>, a line that's indented
3513 3 times will be preceded by one tab and four spaces; if the options were
3514 B<-si8T>, the same line would be preceded by three tabs.
3515
3516 =item B<v>I<STRING>B<.>
3517
3518 Print I<STRING> for the value of a constant that can't be determined
3519 because it was optimized away (mnemonic: this happens when a constant
3520 is used in B<v>oid context). The end of the string is marked by a period.
3521 The string should be a valid perl expression, generally a constant.
3522 Note that unless it's a number, it probably needs to be quoted, and on
3523 a command line quotes need to be protected from the shell. Some
3524 conventional values include 0, 1, 42, '', 'foo', and
3525 'Useless use of constant omitted' (which may need to be
3526 B<-sv"'Useless use of constant omitted'.">
3527 or something similar depending on your shell). The default is '???'.
3528 If you're using B::Deparse on a module or other file that's require'd,
3529 you shouldn't use a value that evaluates to false, since the customary
3530 true constant at the end of a module will be in void context when the
3531 file is compiled as a main program.
3532
3533 =back
3534
3535 =item B<-x>I<LEVEL>
3536
3537 Expand conventional syntax constructions into equivalent ones that expose
3538 their internal operation. I<LEVEL> should be a digit, with higher values
3539 meaning more expansion. As with B<-q>, this actually involves turning off
3540 special cases in B::Deparse's normal operations.
3541
3542 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3543 while loops with continue blocks; for instance
3544
3545     for ($i = 0; $i < 10; ++$i) {
3546         print $i;
3547     }
3548
3549 turns into
3550
3551     $i = 0;
3552     while ($i < 10) {
3553         print $i;
3554     } continue {
3555         ++$i
3556     }
3557
3558 Note that in a few cases this translation can't be perfectly carried back
3559 into the source code -- if the loop's initializer declares a my variable,
3560 for instance, it won't have the correct scope outside of the loop.
3561
3562 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3563 expressions using C<&&>, C<?:> and C<do {}>; for instance
3564
3565     print 'hi' if $nice;
3566     if ($nice) {
3567         print 'hi';
3568     }
3569     if ($nice) {
3570         print 'hi';
3571     } else {
3572         print 'bye';
3573     }
3574
3575 turns into
3576
3577     $nice and print 'hi';
3578     $nice and do { print 'hi' };
3579     $nice ? do { print 'hi' } : do { print 'bye' };
3580
3581 Long sequences of elsifs will turn into nested ternary operators, which
3582 B::Deparse doesn't know how to indent nicely.
3583
3584 =back
3585
3586 =head1 USING B::Deparse AS A MODULE
3587
3588 =head2 Synopsis
3589
3590     use B::Deparse;
3591     $deparse = B::Deparse->new("-p", "-sC");
3592     $body = $deparse->coderef2text(\&func);
3593     eval "sub func $body"; # the inverse operation
3594
3595 =head2 Description
3596
3597 B::Deparse can also be used on a sub-by-sub basis from other perl
3598 programs.
3599
3600 =head2 new
3601
3602     $deparse = B::Deparse->new(OPTIONS)
3603
3604 Create an object to store the state of a deparsing operation and any
3605 options. The options are the same as those that can be given on the
3606 command line (see L</OPTIONS>); options that are separated by commas
3607 after B<-MO=Deparse> should be given as separate strings. Some
3608 options, like B<-u>, don't make sense for a single subroutine, so
3609 don't pass them.
3610
3611 =head2 ambient_pragmas
3612
3613     $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3614
3615 The compilation of a subroutine can be affected by a few compiler
3616 directives, B<pragmas>. These are:
3617
3618 =over 4
3619
3620 =item *
3621
3622 use strict;
3623
3624 =item *
3625
3626 use warnings;
3627
3628 =item *
3629
3630 Assigning to the special variable $[
3631
3632 =item *
3633
3634 use integer;
3635
3636 =item *
3637
3638 use bytes;
3639
3640 =item *
3641
3642 use utf8;
3643
3644 =item *
3645
3646 use re;
3647
3648 =back
3649
3650 Ordinarily, if you use B::Deparse on a subroutine which has
3651 been compiled in the presence of one or more of these pragmas,
3652 the output will include statements to turn on the appropriate
3653 directives. So if you then compile the code returned by coderef2text,
3654 it will behave the same way as the subroutine which you deparsed.
3655
3656 However, you may know that you intend to use the results in a
3657 particular context, where some pragmas are already in scope. In
3658 this case, you use the B<ambient_pragmas> method to describe the
3659 assumptions you wish to make.
3660
3661 The parameters it accepts are:
3662
3663 =over 4
3664
3665 =item strict
3666
3667 Takes a string, possibly containing several values separated
3668 by whitespace. The special values "all" and "none" mean what you'd
3669 expect.
3670
3671     $deparse->ambient_pragmas(strict => 'subs refs');
3672
3673 =item $[
3674
3675 Takes a number, the value of the array base $[.
3676
3677 =item bytes
3678
3679 =item utf8
3680
3681 =item integer
3682
3683 If the value is true, then the appropriate pragma is assumed to
3684 be in the ambient scope, otherwise not.
3685
3686 =item re
3687
3688 Takes a string, possibly containing a whitespace-separated list of
3689 values. The values "all" and "none" are special. It's also permissible
3690 to pass an array reference here.
3691
3692     $deparser->ambient_pragmas(re => 'eval');
3693
3694
3695 =item warnings
3696
3697 Takes a string, possibly containing a whitespace-separated list of
3698 values. The values "all" and "none" are special, again. It's also
3699 permissible to pass an array reference here.
3700
3701     $deparser->ambient_pragmas(warnings => [qw[void io]]);
3702
3703 If one of the values is the string "FATAL", then all the warnings
3704 in that list will be considered fatal, just as with the B<warnings>
3705 pragma itself. Should you need to specify that some warnings are
3706 fatal, and others are merely enabled, you can pass the B<warnings>
3707 parameter twice:
3708
3709     $deparser->ambient_pragmas(
3710         warnings => 'all',
3711         warnings => [FATAL => qw/void io/],
3712     );
3713
3714 See L<perllexwarn> for more information about lexical warnings.
3715
3716 =item hint_bits
3717
3718 =item warning_bits
3719
3720 These two parameters are used to specify the ambient pragmas in
3721 the format used by the special variables $^H and ${^WARNING_BITS}.
3722
3723 They exist principally so that you can write code like:
3724
3725     { my ($hint_bits, $warning_bits);
3726     BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
3727     $deparser->ambient_pragmas (
3728         hint_bits    => $hint_bits,
3729         warning_bits => $warning_bits,
3730         '$['         => 0 + $[
3731     ); }
3732
3733 which specifies that the ambient pragmas are exactly those which
3734 are in scope at the point of calling.
3735
3736 =back
3737
3738 =head2 coderef2text
3739
3740     $body = $deparse->coderef2text(\&func)
3741     $body = $deparse->coderef2text(sub ($$) { ... })
3742
3743 Return source code for the body of a subroutine (a block, optionally
3744 preceded by a prototype in parens), given a reference to the
3745 sub. Because a subroutine can have no names, or more than one name,
3746 this method doesn't return a complete subroutine definition -- if you
3747 want to eval the result, you should prepend "sub subname ", or "sub "
3748 for an anonymous function constructor. Unless the sub was defined in
3749 the main:: package, the code will include a package declaration.
3750
3751 =head1 BUGS
3752
3753 See the 'to do' list at the beginning of the module file.
3754
3755 =head1 AUTHOR
3756
3757 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
3758 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3759 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3760 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.
3761
3762 =cut