ext/B/B/Deparse.pm

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