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
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     my($succeed, $delim);
3162     ($succeed, $str) = balanced_delim($str);
3163     return "$q$str" if $succeed;
3164     for $delim ('/', '"', '#') {
3165         return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3166     }
3167     if ($default) {
3168         $str =~ s/$default/\\$default/g;
3169         return "$default$str$default";
3170     } else {
3171         $str =~ s[/][\\/]g;
3172         return "$q/$str/";
3173     }
3174 }
3175
3176 sub const {
3177     my $sv = shift;
3178     if (class($sv) eq "SPECIAL") {
3179         return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
3180     } elsif (class($sv) eq "NULL") {
3181        return 'undef';
3182     } elsif ($sv->FLAGS & SVf_IOK) {
3183         return $sv->int_value;
3184     } elsif ($sv->FLAGS & SVf_NOK) {
3185         # try the default stringification
3186         my $r = "".$sv->NV;
3187         if ($r =~ /e/) {
3188             # If it's in scientific notation, we might have lost information
3189             return sprintf("%.20e", $sv->NV);
3190         }
3191         return $r;
3192     } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3193         return "\\(" . const($sv->RV) . ")"; # constant folded
3194     } elsif ($sv->FLAGS & SVf_POK) {
3195         my $str = $sv->PV;
3196         if ($str =~ /[^ -~]/) { # ASCII for non-printing
3197             return single_delim("qq", '"', uninterp escape_str unback $str);
3198         } else {
3199             return single_delim("q", "'", unback $str);
3200         }
3201     } else {
3202         return "undef";
3203     }
3204 }
3205
3206 sub const_sv {
3207     my $self = shift;
3208     my $op = shift;
3209     my $sv = $op->sv;
3210     # the constant could be in the pad (under useithreads)
3211     $sv = $self->padval($op->targ) unless $$sv;
3212     return $sv;
3213 }
3214
3215 sub pp_const {
3216     my $self = shift;
3217     my($op, $cx) = @_;
3218     if ($op->private & OPpCONST_ARYBASE) {
3219         return '$[';
3220     }
3221 #    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3222 #       return $self->const_sv($op)->PV;
3223 #    }
3224     my $sv = $self->const_sv($op);
3225 #    return const($sv);
3226     my $c = const $sv;
3227     return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
3228 }
3229
3230 sub dq {
3231     my $self = shift;
3232     my $op = shift;
3233     my $type = $op->name;
3234     if ($type eq "const") {
3235         return '$[' if $op->private & OPpCONST_ARYBASE;
3236         return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3237     } elsif ($type eq "concat") {
3238         my $first = $self->dq($op->first);
3239         my $last  = $self->dq($op->last);
3240
3241         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3242         ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3243             $first =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
3244             || ($last =~ /^[{\[\w_]/ &&
3245                 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3246
3247         return $first . $last;
3248     } elsif ($type eq "uc") {
3249         return '\U' . $self->dq($op->first->sibling) . '\E';
3250     } elsif ($type eq "lc") {
3251         return '\L' . $self->dq($op->first->sibling) . '\E';
3252     } elsif ($type eq "ucfirst") {
3253         return '\u' . $self->dq($op->first->sibling);
3254     } elsif ($type eq "lcfirst") {
3255         return '\l' . $self->dq($op->first->sibling);
3256     } elsif ($type eq "quotemeta") {
3257         return '\Q' . $self->dq($op->first->sibling) . '\E';
3258     } elsif ($type eq "join") {
3259         return $self->deparse($op->last, 26); # was join($", @ary)
3260     } else {
3261         return $self->deparse($op, 26);
3262     }
3263 }
3264
3265 sub pp_backtick {
3266     my $self = shift;
3267     my($op, $cx) = @_;
3268     # skip pushmark
3269     return single_delim("qx", '`', $self->dq($op->first->sibling));
3270 }
3271
3272 sub dquote {
3273     my $self = shift;
3274     my($op, $cx) = @_;
3275     my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3276     return $self->deparse($kid, $cx) if $self->{'unquote'};
3277     $self->maybe_targmy($kid, $cx,
3278                         sub {single_delim("qq", '"', $self->dq($_[1]))});
3279 }
3280
3281 # OP_STRINGIFY is a listop, but it only ever has one arg
3282 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3283
3284 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3285 # note that tr(from)/to/ is OK, but not tr/from/(to)
3286 sub double_delim {
3287     my($from, $to) = @_;
3288     my($succeed, $delim);
3289     if ($from !~ m[/] and $to !~ m[/]) {
3290         return "/$from/$to/";
3291     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3292         if (($succeed, $to) = balanced_delim($to) and $succeed) {
3293             return "$from$to";
3294         } else {
3295             for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3296                 return "$from$delim$to$delim" if index($to, $delim) == -1;
3297             }
3298             $to =~ s[/][\\/]g;
3299             return "$from/$to/";
3300         }
3301     } else {
3302         for $delim ('/', '"', '#') { # note no '
3303             return "$delim$from$delim$to$delim"
3304                 if index($to . $from, $delim) == -1;
3305         }
3306         $from =~ s[/][\\/]g;
3307         $to =~ s[/][\\/]g;
3308         return "/$from/$to/";
3309     }
3310 }
3311
3312 # Only used by tr///, so backslashes hyphens
3313 sub pchr { # ASCII
3314     my($n) = @_;
3315     if ($n == ord '\\') {
3316         return '\\\\';
3317     } elsif ($n == ord "-") {
3318         return "\\-";
3319     } elsif ($n >= ord(' ') and $n <= ord('~')) {
3320         return chr($n);
3321     } elsif ($n == ord "\a") {
3322         return '\\a';
3323     } elsif ($n == ord "\b") {
3324         return '\\b';
3325     } elsif ($n == ord "\t") {
3326         return '\\t';
3327     } elsif ($n == ord "\n") {
3328         return '\\n';
3329     } elsif ($n == ord "\e") {
3330         return '\\e';
3331     } elsif ($n == ord "\f") {
3332         return '\\f';
3333     } elsif ($n == ord "\r") {
3334         return '\\r';
3335     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3336         return '\\c' . chr(ord("@") + $n);
3337     } else {
3338 #       return '\x' . sprintf("%02x", $n);
3339         return '\\' . sprintf("%03o", $n);
3340     }
3341 }
3342
3343 sub collapse {
3344     my(@chars) = @_;
3345     my($str, $c, $tr) = ("");
3346     for ($c = 0; $c < @chars; $c++) {
3347         $tr = $chars[$c];
3348         $str .= pchr($tr);
3349         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3350             $chars[$c + 2] == $tr + 2)
3351         {
3352             for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3353               {}
3354             $str .= "-";
3355             $str .= pchr($chars[$c]);
3356         }
3357     }
3358     return $str;
3359 }
3360
3361 sub tr_decode_byte {
3362     my($table, $flags) = @_;
3363     my(@table) = unpack("s*", $table);
3364     splice @table, 0x100, 1;   # Number of subsequent elements
3365     my($c, $tr, @from, @to, @delfrom, $delhyphen);
3366     if ($table[ord "-"] != -1 and
3367         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3368     {
3369         $tr = $table[ord "-"];
3370         $table[ord "-"] = -1;
3371         if ($tr >= 0) {
3372             @from = ord("-");
3373             @to = $tr;
3374         } else { # -2 ==> delete
3375             $delhyphen = 1;
3376         }
3377     }
3378     for ($c = 0; $c < @table; $c++) {
3379         $tr = $table[$c];
3380         if ($tr >= 0) {
3381             push @from, $c; push @to, $tr;
3382         } elsif ($tr == -2) {
3383             push @delfrom, $c;
3384         }
3385     }
3386     @from = (@from, @delfrom);
3387     if ($flags & OPpTRANS_COMPLEMENT) {
3388         my @newfrom = ();
3389         my %from;
3390         @from{@from} = (1) x @from;
3391         for ($c = 0; $c < 256; $c++) {
3392             push @newfrom, $c unless $from{$c};
3393         }
3394         @from = @newfrom;
3395     }
3396     unless ($flags & OPpTRANS_DELETE || !@to) {
3397         pop @to while $#to and $to[$#to] == $to[$#to -1];
3398     }
3399     my($from, $to);
3400     $from = collapse(@from);
3401     $to = collapse(@to);
3402     $from .= "-" if $delhyphen;
3403     return ($from, $to);
3404 }
3405
3406 sub tr_chr {
3407     my $x = shift;
3408     if ($x == ord "-") {
3409         return "\\-";
3410     } elsif ($x == ord "\\") {
3411         return "\\\\";
3412     } else {
3413         return chr $x;
3414     }
3415 }
3416
3417 # XXX This doesn't yet handle all cases correctly either
3418
3419 sub tr_decode_utf8 {
3420     my($swash_hv, $flags) = @_;
3421     my %swash = $swash_hv->ARRAY;
3422     my $final = undef;
3423     $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3424     my $none = $swash{"NONE"}->IV;
3425     my $extra = $none + 1;
3426     my(@from, @delfrom, @to);
3427     my $line;
3428     foreach $line (split /\n/, $swash{'LIST'}->PV) {
3429         my($min, $max, $result) = split(/\t/, $line);
3430         $min = hex $min;
3431         if (length $max) {
3432             $max = hex $max;
3433         } else {
3434             $max = $min;
3435         }
3436         $result = hex $result;
3437         if ($result == $extra) {
3438             push @delfrom, [$min, $max];
3439         } else {
3440             push @from, [$min, $max];
3441             push @to, [$result, $result + $max - $min];
3442         }
3443     }
3444     for my $i (0 .. $#from) {
3445         if ($from[$i][0] == ord '-') {
3446             unshift @from, splice(@from, $i, 1);
3447             unshift @to, splice(@to, $i, 1);
3448             last;
3449         } elsif ($from[$i][1] == ord '-') {
3450             $from[$i][1]--;
3451             $to[$i][1]--;
3452             unshift @from, ord '-';
3453             unshift @to, ord '-';
3454             last;
3455         }
3456     }
3457     for my $i (0 .. $#delfrom) {
3458         if ($delfrom[$i][0] == ord '-') {
3459             push @delfrom, splice(@delfrom, $i, 1);
3460             last;
3461         } elsif ($delfrom[$i][1] == ord '-') {
3462             $delfrom[$i][1]--;
3463             push @delfrom, ord '-';
3464             last;
3465         }
3466     }
3467     if (defined $final and $to[$#to][1] != $final) {
3468         push @to, [$final, $final];
3469     }
3470     push @from, @delfrom;
3471     if ($flags & OPpTRANS_COMPLEMENT) {
3472         my @newfrom;
3473         my $next = 0;
3474         for my $i (0 .. $#from) {
3475             push @newfrom, [$next, $from[$i][0] - 1];
3476             $next = $from[$i][1] + 1;
3477         }
3478         @from = ();
3479         for my $range (@newfrom) {
3480             if ($range->[0] <= $range->[1]) {
3481                 push @from, $range;
3482             }
3483         }
3484     }
3485     my($from, $to, $diff);
3486     for my $chunk (@from) {
3487         $diff = $chunk->[1] - $chunk->[0];
3488         if ($diff > 1) {
3489             $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3490         } elsif ($diff == 1) {
3491             $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3492         } else {
3493             $from .= tr_chr($chunk->[0]);
3494         }
3495     }
3496     for my $chunk (@to) {
3497         $diff = $chunk->[1] - $chunk->[0];
3498         if ($diff > 1) {
3499             $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3500         } elsif ($diff == 1) {
3501             $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3502         } else {
3503             $to .= tr_chr($chunk->[0]);
3504         }
3505     }
3506     #$final = sprintf("%04x", $final) if defined $final;
3507     #$none = sprintf("%04x", $none) if defined $none;
3508     #$extra = sprintf("%04x", $extra) if defined $extra;
3509     #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3510     #print STDERR $swash{'LIST'}->PV;
3511     return (escape_str($from), escape_str($to));
3512 }
3513
3514 sub pp_trans {
3515     my $self = shift;
3516     my($op, $cx) = @_;
3517     my($from, $to);
3518     if (class($op) eq "PVOP") {
3519         ($from, $to) = tr_decode_byte($op->pv, $op->private);
3520     } else { # class($op) eq "SVOP"
3521         ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3522     }
3523     my $flags = "";
3524     $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3525     $flags .= "d" if $op->private & OPpTRANS_DELETE;
3526     $to = "" if $from eq $to and $flags eq "";
3527     $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3528     return "tr" . double_delim($from, $to) . $flags;
3529 }
3530
3531 # Like dq(), but different
3532 sub re_dq {
3533     my $self = shift;
3534     my ($op, $extended) = @_;
3535
3536     my $type = $op->name;
3537     if ($type eq "const") {
3538         return '$[' if $op->private & OPpCONST_ARYBASE;
3539         my $unbacked = re_unback($self->const_sv($op)->as_string);
3540         return re_uninterp_extended(escape_extended_re($unbacked))
3541             if $extended;
3542         return re_uninterp(escape_str($unbacked));
3543     } elsif ($type eq "concat") {
3544         my $first = $self->re_dq($op->first, $extended);
3545         my $last  = $self->re_dq($op->last,  $extended);
3546
3547         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3548         ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3549             $first =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
3550             || ($last =~ /^[{\[\w_]/ &&
3551                 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3552
3553         return $first . $last;
3554     } elsif ($type eq "uc") {
3555         return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
3556     } elsif ($type eq "lc") {
3557         return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
3558     } elsif ($type eq "ucfirst") {
3559         return '\u' . $self->re_dq($op->first->sibling, $extended);
3560     } elsif ($type eq "lcfirst") {
3561         return '\l' . $self->re_dq($op->first->sibling, $extended);
3562     } elsif ($type eq "quotemeta") {
3563         return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
3564     } elsif ($type eq "join") {
3565         return $self->deparse($op->last, 26); # was join($", @ary)
3566     } else {
3567         return $self->deparse($op, 26);
3568     }
3569 }
3570
3571 sub pure_string {
3572     my ($self, $op) = @_;
3573     my $type = $op->name;
3574
3575     if ($type eq 'const') {
3576         return 1;
3577     }
3578     elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
3579         return $self->pure_string($op->first->sibling);
3580     }
3581     elsif ($type eq 'join') {
3582         my $join_op = $op->first->sibling;  # Skip pushmark
3583         return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
3584
3585         my $gvop = $join_op->first;
3586         return 0 unless $gvop->name eq 'gvsv';
3587         return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
3588
3589         return 0 unless ${$join_op->sibling} eq ${$op->last};
3590         return 0 unless $op->last->name =~ /^(rv2|pad)av$/;
3591     }
3592     elsif ($type eq 'concat') {
3593         return $self->pure_string($op->first)
3594             && $self->pure_string($op->last);
3595     }
3596     elsif (is_scalar($op) || $type =~ /^[ah]elem(fast)?$/) {
3597         return 1;
3598     }
3599     else {
3600         return 0;
3601     }
3602
3603     return 1;
3604 }
3605
3606 sub regcomp {
3607     my $self = shift;
3608     my($op, $cx, $extended) = @_;
3609     my $kid = $op->first;
3610     $kid = $kid->first if $kid->name eq "regcmaybe";
3611     $kid = $kid->first if $kid->name eq "regcreset";
3612     return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
3613     return ($self->deparse($kid, $cx), 0);
3614 }
3615
3616 sub pp_regcomp {
3617     my ($self, $op, $cx) = @_;
3618     return (($self->regcomp($op, $cx, 0))[0]);
3619 }
3620
3621 # osmic acid -- see osmium tetroxide
3622
3623 my %matchwords;
3624 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3625     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3626     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3627
3628 sub matchop {
3629     my $self = shift;
3630     my($op, $cx, $name, $delim) = @_;
3631     my $kid = $op->first;
3632     my ($binop, $var, $re) = ("", "", "");
3633     if ($op->flags & OPf_STACKED) {
3634         $binop = 1;
3635         $var = $self->deparse($kid, 20);
3636         $kid = $kid->sibling;
3637     }
3638     my $quote = 1;
3639     my $extended = ($op->pmflags & PMf_EXTENDED);
3640     if (null $kid) {
3641         my $unbacked = re_unback($op->precomp);
3642         if ($extended) {
3643             $re = re_uninterp_extended(escape_extended_re($unbacked));
3644         } else {
3645             $re = re_uninterp(escape_str(re_unback($op->precomp)));
3646         }
3647     } elsif ($kid->name ne 'regcomp') {
3648         Carp::cluck("found ".$kid->name." where regcomp expected");
3649     } else {
3650         ($re, $quote) = $self->regcomp($kid, 1, $extended);
3651     }
3652     my $flags = "";
3653     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3654     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3655     $flags .= "i" if $op->pmflags & PMf_FOLD;
3656     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3657     $flags .= "o" if $op->pmflags & PMf_KEEP;
3658     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3659     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3660     $flags = $matchwords{$flags} if $matchwords{$flags};
3661     if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3662         $re =~ s/\?/\\?/g;
3663         $re = "?$re?";
3664     } elsif ($quote) {
3665         $re = single_delim($name, $delim, $re);
3666     }
3667     $re = $re . $flags if $quote;
3668     if ($binop) {
3669         return $self->maybe_parens("$var =~ $re", $cx, 20);
3670     } else {
3671         return $re;
3672     }
3673 }
3674
3675 sub pp_match { matchop(@_, "m", "/") }
3676 sub pp_pushre { matchop(@_, "m", "/") }
3677 sub pp_qr { matchop(@_, "qr", "") }
3678
3679 sub pp_split {
3680     my $self = shift;
3681     my($op, $cx) = @_;
3682     my($kid, @exprs, $ary, $expr);
3683     $kid = $op->first;
3684     if ($ {$kid->pmreplroot}) {
3685         $ary = $self->stash_variable('@', $self->gv_name($kid->pmreplroot));
3686     }
3687     for (; !null($kid); $kid = $kid->sibling) {
3688         push @exprs, $self->deparse($kid, 6);
3689     }
3690
3691     # handle special case of split(), and split(" ") that compiles to /\s+/
3692     $kid = $op->first;
3693     if ($kid->flags & OPf_SPECIAL
3694         && $exprs[0] eq '/\\s+/'
3695         && $kid->pmflags & PMf_SKIPWHITE ) {
3696             $exprs[0] = '" "';
3697     }
3698
3699     $expr = "split(" . join(", ", @exprs) . ")";
3700     if ($ary) {
3701         return $self->maybe_parens("$ary = $expr", $cx, 7);
3702     } else {
3703         return $expr;
3704     }
3705 }
3706
3707 # oxime -- any of various compounds obtained chiefly by the action of
3708 # hydroxylamine on aldehydes and ketones and characterized by the
3709 # bivalent grouping C=NOH [Webster's Tenth]
3710
3711 my %substwords;
3712 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3713     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3714     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3715     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3716
3717 sub pp_subst {
3718     my $self = shift;
3719     my($op, $cx) = @_;
3720     my $kid = $op->first;
3721     my($binop, $var, $re, $repl) = ("", "", "", "");
3722     if ($op->flags & OPf_STACKED) {
3723         $binop = 1;
3724         $var = $self->deparse($kid, 20);
3725         $kid = $kid->sibling;
3726     }
3727     my $flags = "";
3728     if (null($op->pmreplroot)) {
3729         $repl = $self->dq($kid);
3730         $kid = $kid->sibling;
3731     } else {
3732         $repl = $op->pmreplroot->first; # skip substcont
3733         while ($repl->name eq "entereval") {
3734             $repl = $repl->first;
3735             $flags .= "e";
3736         }
3737         if ($op->pmflags & PMf_EVAL) {
3738             $repl = $self->deparse($repl, 0);
3739         } else {
3740             $repl = $self->dq($repl);
3741         }
3742     }
3743     my $extended = ($op->pmflags & PMf_EXTENDED);
3744     if (null $kid) {
3745         my $unbacked = re_unback($op->precomp);
3746         if ($extended) {
3747             $re = re_uninterp_extended(escape_extended_re($unbacked));
3748         }
3749         else {
3750             $re = re_uninterp(escape_str($unbacked));
3751         }
3752     } else {
3753         ($re) = $self->regcomp($kid, 1, $extended);
3754     }
3755     $flags .= "e" if $op->pmflags & PMf_EVAL;
3756     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3757     $flags .= "i" if $op->pmflags & PMf_FOLD;
3758     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3759     $flags .= "o" if $op->pmflags & PMf_KEEP;
3760     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3761     $flags .= "x" if $extended;
3762     $flags = $substwords{$flags} if $substwords{$flags};
3763     if ($binop) {
3764         return $self->maybe_parens("$var =~ s"
3765                                    . double_delim($re, $repl) . $flags,
3766                                    $cx, 20);
3767     } else {
3768         return "s". double_delim($re, $repl) . $flags;
3769     }
3770 }
3771
3772 1;
3773 __END__
3774
3775 =head1 NAME
3776
3777 B::Deparse - Perl compiler backend to produce perl code
3778
3779 =head1 SYNOPSIS
3780
3781 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3782         [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3783
3784 =head1 DESCRIPTION
3785
3786 B::Deparse is a backend module for the Perl compiler that generates
3787 perl source code, based on the internal compiled structure that perl
3788 itself creates after parsing a program. The output of B::Deparse won't
3789 be exactly the same as the original source, since perl doesn't keep
3790 track of comments or whitespace, and there isn't a one-to-one
3791 correspondence between perl's syntactical constructions and their
3792 compiled form, but it will often be close. When you use the B<-p>
3793 option, the output also includes parentheses even when they are not
3794 required by precedence, which can make it easy to see if perl is
3795 parsing your expressions the way you intended.
3796
3797 Please note that this module is mainly new and untested code and is
3798 still under development, so it may change in the future.
3799
3800 =head1 OPTIONS
3801
3802 As with all compiler backend options, these must follow directly after
3803 the '-MO=Deparse', separated by a comma but not any white space.
3804
3805 =over 4
3806
3807 =item B<-l>
3808
3809 Add '#line' declarations to the output based on the line and file
3810 locations of the original code.
3811
3812 =item B<-p>
3813
3814 Print extra parentheses. Without this option, B::Deparse includes
3815 parentheses in its output only when they are needed, based on the
3816 structure of your program. With B<-p>, it uses parentheses (almost)
3817 whenever they would be legal. This can be useful if you are used to
3818 LISP, or if you want to see how perl parses your input. If you say
3819
3820     if ($var & 0x7f == 65) {print "Gimme an A!"}
3821     print ($which ? $a : $b), "\n";
3822     $name = $ENV{USER} or "Bob";
3823
3824 C<B::Deparse,-p> will print
3825
3826     if (($var & 0)) {
3827         print('Gimme an A!')
3828     };
3829     (print(($which ? $a : $b)), '???');
3830     (($name = $ENV{'USER'}) or '???')
3831
3832 which probably isn't what you intended (the C<'???'> is a sign that
3833 perl optimized away a constant value).
3834
3835 =item B<-q>
3836
3837 Expand double-quoted strings into the corresponding combinations of
3838 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3839 instance, print
3840
3841     print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3842
3843 as
3844
3845     print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3846           . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3847
3848 Note that the expanded form represents the way perl handles such
3849 constructions internally -- this option actually turns off the reverse
3850 translation that B::Deparse usually does. On the other hand, note that
3851 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3852 of $y into a string before doing the assignment.
3853
3854 =item B<-f>I<FILE>
3855
3856 Normally, B::Deparse deparses the main code of a program, and all the subs
3857 defined in the same file. To include subs defined in other files, pass the
3858 B<-f> option with the filename. You can pass the B<-f> option several times, to
3859 include more than one secondary file.  (Most of the time you don't want to
3860 use it at all.)  You can also use this option to include subs which are
3861 defined in the scope of a B<#line> directive with two parameters.
3862
3863 =item B<-s>I<LETTERS>
3864
3865 Tweak the style of B::Deparse's output. The letters should follow
3866 directly after the 's', with no space or punctuation. The following
3867 options are available:
3868
3869 =over 4
3870
3871 =item B<C>
3872
3873 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3874
3875     if (...) {
3876          ...
3877     } else {
3878          ...
3879     }
3880
3881 instead of
3882
3883     if (...) {
3884          ...
3885     }
3886     else {
3887          ...
3888     }
3889
3890 The default is not to cuddle.
3891
3892 =item B<i>I<NUMBER>
3893
3894 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3895
3896 =item B<T>
3897
3898 Use tabs for each 8 columns of indent. The default is to use only spaces.
3899 For instance, if the style options are B<-si4T>, a line that's indented
3900 3 times will be preceded by one tab and four spaces; if the options were
3901 B<-si8T>, the same line would be preceded by three tabs.
3902
3903 =item B<v>I<STRING>B<.>
3904
3905 Print I<STRING> for the value of a constant that can't be determined
3906 because it was optimized away (mnemonic: this happens when a constant
3907 is used in B<v>oid context). The end of the string is marked by a period.
3908 The string should be a valid perl expression, generally a constant.
3909 Note that unless it's a number, it probably needs to be quoted, and on
3910 a command line quotes need to be protected from the shell. Some
3911 conventional values include 0, 1, 42, '', 'foo', and
3912 'Useless use of constant omitted' (which may need to be
3913 B<-sv"'Useless use of constant omitted'.">
3914 or something similar depending on your shell). The default is '???'.
3915 If you're using B::Deparse on a module or other file that's require'd,
3916 you shouldn't use a value that evaluates to false, since the customary
3917 true constant at the end of a module will be in void context when the
3918 file is compiled as a main program.
3919
3920 =back
3921
3922 =item B<-x>I<LEVEL>
3923
3924 Expand conventional syntax constructions into equivalent ones that expose
3925 their internal operation. I<LEVEL> should be a digit, with higher values
3926 meaning more expansion. As with B<-q>, this actually involves turning off
3927 special cases in B::Deparse's normal operations.
3928
3929 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3930 while loops with continue blocks; for instance
3931
3932     for ($i = 0; $i < 10; ++$i) {
3933         print $i;
3934     }
3935
3936 turns into
3937
3938     $i = 0;
3939     while ($i < 10) {
3940         print $i;
3941     } continue {
3942         ++$i
3943     }
3944
3945 Note that in a few cases this translation can't be perfectly carried back
3946 into the source code -- if the loop's initializer declares a my variable,
3947 for instance, it won't have the correct scope outside of the loop.
3948
3949 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3950 expressions using C<&&>, C<?:> and C<do {}>; for instance
3951
3952     print 'hi' if $nice;
3953     if ($nice) {
3954         print 'hi';
3955     }
3956     if ($nice) {
3957         print 'hi';
3958     } else {
3959         print 'bye';
3960     }
3961
3962 turns into
3963
3964     $nice and print 'hi';
3965     $nice and do { print 'hi' };
3966     $nice ? do { print 'hi' } : do { print 'bye' };
3967
3968 Long sequences of elsifs will turn into nested ternary operators, which
3969 B::Deparse doesn't know how to indent nicely.
3970
3971 =back
3972
3973 =head1 USING B::Deparse AS A MODULE
3974
3975 =head2 Synopsis
3976
3977     use B::Deparse;
3978     $deparse = B::Deparse->new("-p", "-sC");
3979     $body = $deparse->coderef2text(\&func);
3980     eval "sub func $body"; # the inverse operation
3981
3982 =head2 Description
3983
3984 B::Deparse can also be used on a sub-by-sub basis from other perl
3985 programs.
3986
3987 =head2 new
3988
3989     $deparse = B::Deparse->new(OPTIONS)
3990
3991 Create an object to store the state of a deparsing operation and any
3992 options. The options are the same as those that can be given on the
3993 command line (see L</OPTIONS>); options that are separated by commas
3994 after B<-MO=Deparse> should be given as separate strings. Some
3995 options, like B<-u>, don't make sense for a single subroutine, so
3996 don't pass them.
3997
3998 =head2 ambient_pragmas
3999
4000     $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
4001
4002 The compilation of a subroutine can be affected by a few compiler
4003 directives, B<pragmas>. These are:
4004
4005 =over 4
4006
4007 =item *
4008
4009 use strict;
4010
4011 =item *
4012
4013 use warnings;
4014
4015 =item *
4016
4017 Assigning to the special variable $[
4018
4019 =item *
4020
4021 use integer;
4022
4023 =item *
4024
4025 use bytes;
4026
4027 =item *
4028
4029 use utf8;
4030
4031 =item *
4032
4033 use re;
4034
4035 =back
4036
4037 Ordinarily, if you use B::Deparse on a subroutine which has
4038 been compiled in the presence of one or more of these pragmas,
4039 the output will include statements to turn on the appropriate
4040 directives. So if you then compile the code returned by coderef2text,
4041 it will behave the same way as the subroutine which you deparsed.
4042
4043 However, you may know that you intend to use the results in a
4044 particular context, where some pragmas are already in scope. In
4045 this case, you use the B<ambient_pragmas> method to describe the
4046 assumptions you wish to make.
4047
4048 Not all of the options currently have any useful effect. See
4049 L</BUGS> for more details.
4050
4051 The parameters it accepts are:
4052
4053 =over 4
4054
4055 =item strict
4056
4057 Takes a string, possibly containing several values separated
4058 by whitespace. The special values "all" and "none" mean what you'd
4059 expect.
4060
4061     $deparse->ambient_pragmas(strict => 'subs refs');
4062
4063 =item $[
4064
4065 Takes a number, the value of the array base $[.
4066
4067 =item bytes
4068
4069 =item utf8
4070
4071 =item integer
4072
4073 If the value is true, then the appropriate pragma is assumed to
4074 be in the ambient scope, otherwise not.
4075
4076 =item re
4077
4078 Takes a string, possibly containing a whitespace-separated list of
4079 values. The values "all" and "none" are special. It's also permissible
4080 to pass an array reference here.
4081
4082     $deparser->ambient_pragmas(re => 'eval');
4083
4084
4085 =item warnings
4086
4087 Takes a string, possibly containing a whitespace-separated list of
4088 values. The values "all" and "none" are special, again. It's also
4089 permissible to pass an array reference here.
4090
4091     $deparser->ambient_pragmas(warnings => [qw[void io]]);
4092
4093 If one of the values is the string "FATAL", then all the warnings
4094 in that list will be considered fatal, just as with the B<warnings>
4095 pragma itself. Should you need to specify that some warnings are
4096 fatal, and others are merely enabled, you can pass the B<warnings>
4097 parameter twice:
4098
4099     $deparser->ambient_pragmas(
4100         warnings => 'all',
4101         warnings => [FATAL => qw/void io/],
4102     );
4103
4104 See L<perllexwarn> for more information about lexical warnings.
4105
4106 =item hint_bits
4107
4108 =item warning_bits
4109
4110 These two parameters are used to specify the ambient pragmas in
4111 the format used by the special variables $^H and ${^WARNING_BITS}.
4112
4113 They exist principally so that you can write code like:
4114
4115     { my ($hint_bits, $warning_bits);
4116     BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
4117     $deparser->ambient_pragmas (
4118         hint_bits    => $hint_bits,
4119         warning_bits => $warning_bits,
4120         '$['         => 0 + $[
4121     ); }
4122
4123 which specifies that the ambient pragmas are exactly those which
4124 are in scope at the point of calling.
4125
4126 =back
4127
4128 =head2 coderef2text
4129
4130     $body = $deparse->coderef2text(\&func)
4131     $body = $deparse->coderef2text(sub ($$) { ... })
4132
4133 Return source code for the body of a subroutine (a block, optionally
4134 preceded by a prototype in parens), given a reference to the
4135 sub. Because a subroutine can have no names, or more than one name,
4136 this method doesn't return a complete subroutine definition -- if you
4137 want to eval the result, you should prepend "sub subname ", or "sub "
4138 for an anonymous function constructor. Unless the sub was defined in
4139 the main:: package, the code will include a package declaration.
4140
4141 =head1 BUGS
4142
4143 =over 4
4144
4145 =item *
4146
4147 The only pragmas to be completely supported are: C<use warnings>,
4148 C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
4149 behaves like a pragma, is also supported.)
4150
4151 Excepting those listed above, we're currently unable to guarantee that
4152 B::Deparse will produce a pragma at the correct point in the program.
4153 Since the effects of pragmas are often lexically scoped, this can mean
4154 that the pragma holds sway over a different portion of the program
4155 than in the input file.
4156
4157 =item *
4158
4159 In fact, the above is a specific instance of a more general problem:
4160 we can't guarantee to produce BEGIN blocks or C<use> declarations in
4161 exactly the right place. So if you use a module which affects compilation
4162 (such as by over-riding keywords, overloading constants or whatever)
4163 then the output code might not work as intended.
4164
4165 This is the most serious outstanding problem, and will be very hard
4166 to fix.
4167
4168 =item *
4169
4170 If a keyword is over-ridden, and your program explicitly calls
4171 the built-in version by using CORE::keyword, the output of B::Deparse
4172 will not reflect this. If you run the resulting code, it will call
4173 the over-ridden version rather than the built-in one. (Maybe there
4174 should be an option to B<always> print keyword calls as C<CORE::name>.)
4175
4176 =item *
4177
4178 C<sort foo (1, 2, 3)> comes out as C<sort (foo 1, 2, 3)>, which
4179 causes perl to issue a warning.
4180
4181 The obvious fix doesn't work, because these are different:
4182
4183     print (FOO 1, 2, 3), 4, 5, 6;
4184     print FOO (1, 2, 3), 4, 5, 6;
4185
4186 =item *
4187
4188 Constants (other than simple strings or numbers) don't work properly.
4189 Pathological examples that fail (and probably always will) include:
4190
4191     use constant E2BIG => ($!=7);
4192     use constant x=>\$x; print x
4193
4194 The following could (and should) be made to work:
4195
4196     use constant regex => qr/blah/;
4197     print regex;
4198
4199 =item *
4200
4201 An input file that uses source filtering probably won't be deparsed into
4202 runnable code, because it will still include the B<use> declaration
4203 for the source filtering module, even though the code that is
4204 produced is already ordinary Perl which shouldn't be filtered again.
4205
4206 =item *
4207
4208 There are probably many more bugs on non-ASCII platforms (EBCDIC).
4209
4210 =back
4211
4212 =head1 AUTHOR
4213
4214 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
4215 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
4216 contributions from Gisle Aas, James Duncan, Albert Dvornik, Robin
4217 Houston, Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons,
4218 and Rafael Garcia-Suarez.
4219
4220 =cut