ext/B/B/Deparse.pm

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