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