ext/B/B/Deparse.pm

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