ext/B/B/Deparse.pm

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