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