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