ext/B/B/Deparse.pm

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