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