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