ext/B/B/Deparse.pm

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