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