ext/B/B/Deparse.pm

   1 # B::Deparse.pm
   2 # Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved.
   3 # This module is free software; you can redistribute and/or modify
   4 # it under the same terms as Perl itself.
   5
   6 # This is based on the module of the same name by Malcolm Beattie,
   7 # but essentially none of his code remains.
   8
   9 package B::Deparse;
  10 use Carp 'cluck', 'croak';
  11 use B qw(class main_root main_start main_cv svref_2object opnumber cstring
  12          OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
  13          OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
  14          OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
  15          OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
  16          OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
  17          OPpSORT_REVERSE
  18          SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR
  19          CVf_METHOD CVf_LOCKED CVf_LVALUE
  20          PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
  21          PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
  22 $VERSION = 0.62;
  23 use strict;
  24 use warnings ();
  25
  26 # Changes between 0.50 and 0.51:
  27 # - fixed nulled leave with live enter in sort { }
  28 # - fixed reference constants (\"str")
  29 # - handle empty programs gracefully
  30 # - handle infinte loops (for (;;) {}, while (1) {})
  31 # - differentiate between `for my $x ...' and `my $x; for $x ...'
  32 # - various minor cleanups
  33 # - moved globals into an object
  34 # - added `-u', like B::C
  35 # - package declarations using cop_stash
  36 # - subs, formats and code sorted by cop_seq
  37 # Changes between 0.51 and 0.52:
  38 # - added pp_threadsv (special variables under USE_5005THREADS)
  39 # - added documentation
  40 # Changes between 0.52 and 0.53:
  41 # - many changes adding precedence contexts and associativity
  42 # - added `-p' and `-s' output style options
  43 # - various other minor fixes
  44 # Changes between 0.53 and 0.54:
  45 # - added support for new `for (1..100)' optimization,
  46 #   thanks to Gisle Aas
  47 # Changes between 0.54 and 0.55:
  48 # - added support for new qr// construct
  49 # - added support for new pp_regcreset OP
  50 # Changes between 0.55 and 0.56:
  51 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
  52 # - fixed $# on non-lexicals broken in last big rewrite
  53 # - added temporary fix for change in opcode of OP_STRINGIFY
  54 # - fixed problem in 0.54's for() patch in `for (@ary)'
  55 # - fixed precedence in conditional of ?:
  56 # - tweaked list paren elimination in `my($x) = @_'
  57 # - made continue-block detection trickier wrt. null ops
  58 # - fixed various prototype problems in pp_entersub
  59 # - added support for sub prototypes that never get GVs
  60 # - added unquoting for special filehandle first arg in truncate
  61 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
  62 # - added semicolons at the ends of blocks
  63 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
  64 # Changes between 0.56 and 0.561:
  65 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
  66 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
  67 # Changes between 0.561 and 0.57:
  68 # - stylistic changes to symbolic constant stuff
  69 # - handled scope in s///e replacement code
  70 # - added unquote option for expanding "" into concats, etc.
  71 # - split method and proto parts of pp_entersub into separate functions
  72 # - various minor cleanups
  73 # Changes after 0.57:
  74 # - added parens in \&foo (patch by Albert Dvornik)
  75 # Changes between 0.57 and 0.58:
  76 # - fixed `0' statements that weren't being printed
  77 # - added methods for use from other programs
  78 #   (based on patches from James Duncan and Hugo van der Sanden)
  79 # - added -si and -sT to control indenting (also based on a patch from Hugo)
  80 # - added -sv to print something else instead of '???'
  81 # - preliminary version of utf8 tr/// handling
  82 # Changes after 0.58:
  83 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
  84 # - added support for Hugo's new OP_SETSTATE (like nextstate)
  85 # Changes between 0.58 and 0.59
  86 # - added support for Chip's OP_METHOD_NAMED
  87 # - added support for Ilya's OPpTARGET_MY optimization
  88 # - elided arrows before `()' subscripts when possible
  89 # Changes between 0.59 and 0.60
  90 # - support for method attribues was added
  91 # - some warnings fixed
  92 # - separate recognition of constant subs
  93 # - rewrote continue block handling, now recoginizing for loops
  94 # - added more control of expanding control structures
  95 # Changes between 0.60 and 0.61 (mostly by Robin Houston)
  96 # - many bug-fixes
  97 # - support for pragmas and 'use'
  98 # - support for the little-used $[ variable
  99 # - support for __DATA__ sections
 100 # - UTF8 support
 101 # - BEGIN, CHECK, INIT and END blocks
 102 # - scoping of subroutine declarations fixed
 103 # - compile-time output from the input program can be suppressed, so that the
 104 #   output is just the deparsed code. (a change to O.pm in fact)
 105 # - our() declarations
 106 # - *all* the known bugs are now listed in the BUGS section
 107 # - comprehensive test mechanism (TEST -deparse)
 108
 109 # Todo:
 110 #  (See also BUGS section at the end of this file)
 111 #
 112 # - finish tr/// changes
 113 # - add option for even more parens (generalize \&foo change)
 114 # - left/right context
 115 # - treat top-level block specially for incremental output
 116 # - copy comments (look at real text with $^P?)
 117 # - avoid semis in one-statement blocks
 118 # - associativity of &&=, ||=, ?:
 119 # - ',' => '=>' (auto-unquote?)
 120 # - break long lines ("\r" as discretionary break?)
 121 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
 122 # - more style options: brace style, hex vs. octal, quotes, ...
 123 # - print big ints as hex/octal instead of decimal (heuristic?)
 124 # - handle `my $x if 0'?
 125 # - coordinate with Data::Dumper (both directions? see previous)
 126 # - version using op_next instead of op_first/sibling?
 127 # - avoid string copies (pass arrays, one big join?)
 128 # - here-docs?
 129
 130 # Tests that will always fail:
 131 # (see t/TEST for the short list)
 132
 133 # Object fields (were globals):
 134 #
 135 # avoid_local:
 136 # (local($a), local($b)) and local($a, $b) have the same internal
 137 # representation but the short form looks better. We notice we can
 138 # use a large-scale local when checking the list, but need to prevent
 139 # individual locals too. This hash holds the addresses of OPs that
 140 # have already had their local-ness accounted for. The same thing
 141 # is done with my().
 142 #
 143 # curcv:
 144 # CV for current sub (or main program) being deparsed
 145 #
 146 # curcvlex:
 147 # Cached hash of lexical variables for curcv: keys are names,
 148 # each value is an array of pairs, indicating the cop_seq of scopes
 149 # in which a var of that name is valid.
 150 #
 151 # curcop:
 152 # COP for statement being deparsed
 153 #
 154 # curstash:
 155 # name of the current package for deparsed code
 156 #
 157 # subs_todo:
 158 # array of [cop_seq, CV, is_format?] for subs and formats we still
 159 # want to deparse
 160 #
 161 # protos_todo:
 162 # as above, but [name, prototype] for subs that never got a GV
 163 #
 164 # subs_done, forms_done:
 165 # keys are addresses of GVs for subs and formats we've already
 166 # deparsed (or at least put into subs_todo)
 167 #
 168 # subs_declared
 169 # keys are names of subs for which we've printed declarations.
 170 # That means we can omit parentheses from the arguments.
 171 #
 172 # 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     cluck "unexpected OP_ENTER";
 956     return "XXX";
 957 }
 958
 959 sub pp_pushmark { # see also list
 960     cluck "unexpected OP_PUSHMARK";
 961     return "XXX";
 962 }
 963
 964 sub pp_leavesub { # see also deparse_sub
 965     cluck "unexpected OP_LEAVESUB";
 966     return "XXX";
 967 }
 968
 969 sub pp_leavewrite { # see also deparse_format
 970     cluck "unexpected OP_LEAVEWRITE";
 971     return "XXX";
 972 }
 973
 974 sub pp_method { # see also entersub
 975     cluck "unexpected OP_METHOD";
 976     return "XXX";
 977 }
 978
 979 sub pp_regcmaybe { # see also regcomp
 980     cluck "unexpected OP_REGCMAYBE";
 981     return "XXX";
 982 }
 983
 984 sub pp_regcreset { # see also regcomp
 985     cluck "unexpected OP_REGCRESET";
 986     return "XXX";
 987 }
 988
 989 sub pp_substcont { # see also subst
 990     cluck "unexpected OP_SUBSTCONT";
 991     return "XXX";
 992 }
 993
 994 sub pp_grepstart { # see also grepwhile
 995     cluck "unexpected OP_GREPSTART";
 996     return "XXX";
 997 }
 998
 999 sub pp_mapstart { # see also mapwhile
1000     cluck "unexpected OP_MAPSTART";
1001     return "XXX";
1002 }
1003
1004 sub pp_method_named {
1005     cluck "unexpected OP_METHOD_NAMED";
1006     return "XXX";
1007 }
1008
1009 sub pp_flip { # see also flop
1010     cluck "unexpected OP_FLIP";
1011     return "XXX";
1012 }
1013
1014 sub pp_iter { # see also leaveloop
1015     cluck "unexpected OP_ITER";
1016     return "XXX";
1017 }
1018
1019 sub pp_enteriter { # see also leaveloop
1020     cluck "unexpected OP_ENTERITER";
1021     return "XXX";
1022 }
1023
1024 sub pp_enterloop { # see also leaveloop
1025     cluck "unexpected OP_ENTERLOOP";
1026     return "XXX";
1027 }
1028
1029 sub pp_leaveeval { # see also entereval
1030     cluck "unexpected OP_LEAVEEVAL";
1031     return "XXX";
1032 }
1033
1034 sub pp_entertry { # see also leavetry
1035     cluck "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::cluck() 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     #cluck "curcv was undef" unless $self->{curcv};
1624     return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1625 }
1626
1627 sub pp_refgen {
1628     my $self = shift;
1629     my($op, $cx) = @_;
1630     my $kid = $op->first;
1631     if ($kid->name eq "null") {
1632         $kid = $kid->first;
1633         if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1634             my($pre, $post) = @{{"anonlist" => ["[","]"],
1635                                  "anonhash" => ["{","}"]}->{$kid->name}};
1636             my($expr, @exprs);
1637             $kid = $kid->first->sibling; # skip pushmark
1638             for (; !null($kid); $kid = $kid->sibling) {
1639                 $expr = $self->deparse($kid, 6);
1640                 push @exprs, $expr;
1641             }
1642             return $pre . join(", ", @exprs) . $post;
1643         } elsif (!null($kid->sibling) and
1644                  $kid->sibling->name eq "anoncode") {
1645             return "sub " .
1646                 $self->deparse_sub($self->padval($kid->sibling->targ));
1647         } elsif ($kid->name eq "pushmark") {
1648             my $sib_name = $kid->sibling->name;
1649             if ($sib_name =~ /^(pad|rv2)[ah]v$/
1650                 and not $kid->sibling->flags & OPf_REF)
1651             {
1652                 # The @a in \(@a) isn't in ref context, but only when the
1653                 # parens are there.
1654                 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1655             } elsif ($sib_name eq 'entersub') {
1656                 my $text = $self->deparse($kid->sibling, 1);
1657                 # Always show parens for \(&func()), but only with -p otherwise
1658                 $text = "($text)" if $self->{'parens'}
1659                                  or $kid->sibling->private & OPpENTERSUB_AMPER;
1660                 return "\\$text";
1661             }
1662         }
1663     }
1664     $self->pfixop($op, $cx, "\\", 20);
1665 }
1666
1667 sub pp_srefgen { pp_refgen(@_) }
1668
1669 sub pp_readline {
1670     my $self = shift;
1671     my($op, $cx) = @_;
1672     my $kid = $op->first;
1673     $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1674     return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
1675     return $self->unop($op, $cx, "readline");
1676 }
1677
1678 sub pp_rcatline {
1679     my $self = shift;
1680     my($op) = @_;
1681     return "<" . $self->gv_name($op->gv) . ">";
1682 }
1683
1684 # Unary operators that can occur as pseudo-listops inside double quotes
1685 sub dq_unop {
1686     my $self = shift;
1687     my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1688     my $kid;
1689     if ($op->flags & OPf_KIDS) {
1690        $kid = $op->first;
1691        # If there's more than one kid, the first is an ex-pushmark.
1692        $kid = $kid->sibling if not null $kid->sibling;
1693        return $self->maybe_parens_unop($name, $kid, $cx);
1694     } else {
1695        return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");
1696     }
1697 }
1698
1699 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1700 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1701 sub pp_uc { dq_unop(@_, "uc") }
1702 sub pp_lc { dq_unop(@_, "lc") }
1703 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1704
1705 sub loopex {
1706     my $self = shift;
1707     my ($op, $cx, $name) = @_;
1708     if (class($op) eq "PVOP") {
1709         return "$name " . $op->pv;
1710     } elsif (class($op) eq "OP") {
1711         return $name;
1712     } elsif (class($op) eq "UNOP") {
1713         # Note -- loop exits are actually exempt from the
1714         # looks-like-a-func rule, but a few extra parens won't hurt
1715         return $self->maybe_parens_unop($name, $op->first, $cx);
1716     }
1717 }
1718
1719 sub pp_last { loopex(@_, "last") }
1720 sub pp_next { loopex(@_, "next") }
1721 sub pp_redo { loopex(@_, "redo") }
1722 sub pp_goto { loopex(@_, "goto") }
1723 sub pp_dump { loopex(@_, "dump") }
1724
1725 sub ftst {
1726     my $self = shift;
1727     my($op, $cx, $name) = @_;
1728     if (class($op) eq "UNOP") {
1729         # Genuine `-X' filetests are exempt from the LLAFR, but not
1730         # l?stat(); for the sake of clarity, give'em all parens
1731         return $self->maybe_parens_unop($name, $op->first, $cx);
1732     } elsif (class($op) eq "SVOP") {
1733         return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1734     } else { # I don't think baseop filetests ever survive ck_ftst, but...
1735         return $name;
1736     }
1737 }
1738
1739 sub pp_lstat { ftst(@_, "lstat") }
1740 sub pp_stat { ftst(@_, "stat") }
1741 sub pp_ftrread { ftst(@_, "-R") }
1742 sub pp_ftrwrite { ftst(@_, "-W") }
1743 sub pp_ftrexec { ftst(@_, "-X") }
1744 sub pp_fteread { ftst(@_, "-r") }
1745 sub pp_ftewrite { ftst(@_, "-w") }
1746 sub pp_fteexec { ftst(@_, "-x") }
1747 sub pp_ftis { ftst(@_, "-e") }
1748 sub pp_fteowned { ftst(@_, "-O") }
1749 sub pp_ftrowned { ftst(@_, "-o") }
1750 sub pp_ftzero { ftst(@_, "-z") }
1751 sub pp_ftsize { ftst(@_, "-s") }
1752 sub pp_ftmtime { ftst(@_, "-M") }
1753 sub pp_ftatime { ftst(@_, "-A") }
1754 sub pp_ftctime { ftst(@_, "-C") }
1755 sub pp_ftsock { ftst(@_, "-S") }
1756 sub pp_ftchr { ftst(@_, "-c") }
1757 sub pp_ftblk { ftst(@_, "-b") }
1758 sub pp_ftfile { ftst(@_, "-f") }
1759 sub pp_ftdir { ftst(@_, "-d") }
1760 sub pp_ftpipe { ftst(@_, "-p") }
1761 sub pp_ftlink { ftst(@_, "-l") }
1762 sub pp_ftsuid { ftst(@_, "-u") }
1763 sub pp_ftsgid { ftst(@_, "-g") }
1764 sub pp_ftsvtx { ftst(@_, "-k") }
1765 sub pp_fttty { ftst(@_, "-t") }
1766 sub pp_fttext { ftst(@_, "-T") }
1767 sub pp_ftbinary { ftst(@_, "-B") }
1768
1769 sub SWAP_CHILDREN () { 1 }
1770 sub ASSIGN () { 2 } # has OP= variant
1771 sub LIST_CONTEXT () { 4 } # Assignment is in list context
1772
1773 my(%left, %right);
1774
1775 sub assoc_class {
1776     my $op = shift;
1777     my $name = $op->name;
1778     if ($name eq "concat" and $op->first->name eq "concat") {
1779         # avoid spurious `=' -- see comment in pp_concat
1780         return "concat";
1781     }
1782     if ($name eq "null" and class($op) eq "UNOP"
1783         and $op->first->name =~ /^(and|x?or)$/
1784         and null $op->first->sibling)
1785     {
1786         # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1787         # with a null that's used as the common end point of the two
1788         # flows of control. For precedence purposes, ignore it.
1789         # (COND_EXPRs have these too, but we don't bother with
1790         # their associativity).
1791         return assoc_class($op->first);
1792     }
1793     return $name . ($op->flags & OPf_STACKED ? "=" : "");
1794 }
1795
1796 # Left associative operators, like `+', for which
1797 # $a + $b + $c is equivalent to ($a + $b) + $c
1798
1799 BEGIN {
1800     %left = ('multiply' => 19, 'i_multiply' => 19,
1801              'divide' => 19, 'i_divide' => 19,
1802              'modulo' => 19, 'i_modulo' => 19,
1803              'repeat' => 19,
1804              'add' => 18, 'i_add' => 18,
1805              'subtract' => 18, 'i_subtract' => 18,
1806              'concat' => 18,
1807              'left_shift' => 17, 'right_shift' => 17,
1808              'bit_and' => 13,
1809              'bit_or' => 12, 'bit_xor' => 12,
1810              'and' => 3,
1811              'or' => 2, 'xor' => 2,
1812             );
1813 }
1814
1815 sub deparse_binop_left {
1816     my $self = shift;
1817     my($op, $left, $prec) = @_;
1818     if ($left{assoc_class($op)} && $left{assoc_class($left)}
1819         and $left{assoc_class($op)} == $left{assoc_class($left)})
1820     {
1821         return $self->deparse($left, $prec - .00001);
1822     } else {
1823         return $self->deparse($left, $prec);
1824     }
1825 }
1826
1827 # Right associative operators, like `=', for which
1828 # $a = $b = $c is equivalent to $a = ($b = $c)
1829
1830 BEGIN {
1831     %right = ('pow' => 22,
1832               'sassign=' => 7, 'aassign=' => 7,
1833               'multiply=' => 7, 'i_multiply=' => 7,
1834               'divide=' => 7, 'i_divide=' => 7,
1835               'modulo=' => 7, 'i_modulo=' => 7,
1836               'repeat=' => 7,
1837               'add=' => 7, 'i_add=' => 7,
1838               'subtract=' => 7, 'i_subtract=' => 7,
1839               'concat=' => 7,
1840               'left_shift=' => 7, 'right_shift=' => 7,
1841               'bit_and=' => 7,
1842               'bit_or=' => 7, 'bit_xor=' => 7,
1843               'andassign' => 7,
1844               'orassign' => 7,
1845              );
1846 }
1847
1848 sub deparse_binop_right {
1849     my $self = shift;
1850     my($op, $right, $prec) = @_;
1851     if ($right{assoc_class($op)} && $right{assoc_class($right)}
1852         and $right{assoc_class($op)} == $right{assoc_class($right)})
1853     {
1854         return $self->deparse($right, $prec - .00001);
1855     } else {
1856         return $self->deparse($right, $prec);
1857     }
1858 }
1859
1860 sub binop {
1861     my $self = shift;
1862     my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1863     my $left = $op->first;
1864     my $right = $op->last;
1865     my $eq = "";
1866     if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1867         $eq = "=";
1868         $prec = 7;
1869     }
1870     if ($flags & SWAP_CHILDREN) {
1871         ($left, $right) = ($right, $left);
1872     }
1873     $left = $self->deparse_binop_left($op, $left, $prec);
1874     $left = "($left)" if $flags & LIST_CONTEXT
1875                 && $left !~ /^(my|our|local|)[\@\(]/;
1876     $right = $self->deparse_binop_right($op, $right, $prec);
1877     return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1878 }
1879
1880 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1881 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1882 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18,  ASSIGN) }
1883 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1884 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1885 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1886 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1887 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1888 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1889 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1890 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1891
1892 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1893 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1894 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1895 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1896 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1897
1898 sub pp_eq { binop(@_, "==", 14) }
1899 sub pp_ne { binop(@_, "!=", 14) }
1900 sub pp_lt { binop(@_, "<", 15) }
1901 sub pp_gt { binop(@_, ">", 15) }
1902 sub pp_ge { binop(@_, ">=", 15) }
1903 sub pp_le { binop(@_, "<=", 15) }
1904 sub pp_ncmp { binop(@_, "<=>", 14) }
1905 sub pp_i_eq { binop(@_, "==", 14) }
1906 sub pp_i_ne { binop(@_, "!=", 14) }
1907 sub pp_i_lt { binop(@_, "<", 15) }
1908 sub pp_i_gt { binop(@_, ">", 15) }
1909 sub pp_i_ge { binop(@_, ">=", 15) }
1910 sub pp_i_le { binop(@_, "<=", 15) }
1911 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1912
1913 sub pp_seq { binop(@_, "eq", 14) }
1914 sub pp_sne { binop(@_, "ne", 14) }
1915 sub pp_slt { binop(@_, "lt", 15) }
1916 sub pp_sgt { binop(@_, "gt", 15) }
1917 sub pp_sge { binop(@_, "ge", 15) }
1918 sub pp_sle { binop(@_, "le", 15) }
1919 sub pp_scmp { binop(@_, "cmp", 14) }
1920
1921 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1922 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
1923
1924 # `.' is special because concats-of-concats are optimized to save copying
1925 # by making all but the first concat stacked. The effect is as if the
1926 # programmer had written `($a . $b) .= $c', except legal.
1927 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1928 sub real_concat {
1929     my $self = shift;
1930     my($op, $cx) = @_;
1931     my $left = $op->first;
1932     my $right = $op->last;
1933     my $eq = "";
1934     my $prec = 18;
1935     if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1936         $eq = "=";
1937         $prec = 7;
1938     }
1939     $left = $self->deparse_binop_left($op, $left, $prec);
1940     $right = $self->deparse_binop_right($op, $right, $prec);
1941     return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1942 }
1943
1944 # `x' is weird when the left arg is a list
1945 sub pp_repeat {
1946     my $self = shift;
1947     my($op, $cx) = @_;
1948     my $left = $op->first;
1949     my $right = $op->last;
1950     my $eq = "";
1951     my $prec = 19;
1952     if ($op->flags & OPf_STACKED) {
1953         $eq = "=";
1954         $prec = 7;
1955     }
1956     if (null($right)) { # list repeat; count is inside left-side ex-list
1957         my $kid = $left->first->sibling; # skip pushmark
1958         my @exprs;
1959         for (; !null($kid->sibling); $kid = $kid->sibling) {
1960             push @exprs, $self->deparse($kid, 6);
1961         }
1962         $right = $kid;
1963         $left = "(" . join(", ", @exprs). ")";
1964     } else {
1965         $left = $self->deparse_binop_left($op, $left, $prec);
1966     }
1967     $right = $self->deparse_binop_right($op, $right, $prec);
1968     return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1969 }
1970
1971 sub range {
1972     my $self = shift;
1973     my ($op, $cx, $type) = @_;
1974     my $left = $op->first;
1975     my $right = $left->sibling;
1976     $left = $self->deparse($left, 9);
1977     $right = $self->deparse($right, 9);
1978     return $self->maybe_parens("$left $type $right", $cx, 9);
1979 }
1980
1981 sub pp_flop {
1982     my $self = shift;
1983     my($op, $cx) = @_;
1984     my $flip = $op->first;
1985     my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1986     return $self->range($flip->first, $cx, $type);
1987 }
1988
1989 # one-line while/until is handled in pp_leave
1990
1991 sub logop {
1992     my $self = shift;
1993     my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1994     my $left = $op->first;
1995     my $right = $op->first->sibling;
1996     if ($cx == 0 and is_scope($right) and $blockname
1997         and $self->{'expand'} < 7)
1998     { # if ($a) {$b}
1999         $left = $self->deparse($left, 1);
2000         $right = $self->deparse($right, 0);
2001         return "$blockname ($left) {\n\t$right\n\b}\cK";
2002     } elsif ($cx == 0 and $blockname and not $self->{'parens'}
2003              and $self->{'expand'} < 7) { # $b if $a
2004         $right = $self->deparse($right, 1);
2005         $left = $self->deparse($left, 1);
2006         return "$right $blockname $left";
2007     } elsif ($cx > $lowprec and $highop) { # $a && $b
2008         $left = $self->deparse_binop_left($op, $left, $highprec);
2009         $right = $self->deparse_binop_right($op, $right, $highprec);
2010         return $self->maybe_parens("$left $highop $right", $cx, $highprec);
2011     } else { # $a and $b
2012         $left = $self->deparse_binop_left($op, $left, $lowprec);
2013         $right = $self->deparse_binop_right($op, $right, $lowprec);
2014         return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
2015     }
2016 }
2017
2018 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
2019 sub pp_or  { logop(@_, "or",  2, "||", 10, "unless") }
2020
2021 # xor is syntactically a logop, but it's really a binop (contrary to
2022 # old versions of opcode.pl). Syntax is what matters here.
2023 sub pp_xor { logop(@_, "xor", 2, "",   0,  "") }
2024
2025 sub logassignop {
2026     my $self = shift;
2027     my ($op, $cx, $opname) = @_;
2028     my $left = $op->first;
2029     my $right = $op->first->sibling->first; # skip sassign
2030     $left = $self->deparse($left, 7);
2031     $right = $self->deparse($right, 7);
2032     return $self->maybe_parens("$left $opname $right", $cx, 7);
2033 }
2034
2035 sub pp_andassign { logassignop(@_, "&&=") }
2036 sub pp_orassign { logassignop(@_, "||=") }
2037
2038 sub listop {
2039     my $self = shift;
2040     my($op, $cx, $name) = @_;
2041     my(@exprs);
2042     my $parens = ($cx >= 5) || $self->{'parens'};
2043     my $kid = $op->first->sibling;
2044     return $name if null $kid;
2045     my $first;
2046     if (defined prototype("CORE::$name")
2047         && prototype("CORE::$name") =~ /^;?\*/
2048         && $kid->name eq "rv2gv") {
2049         $first = $self->deparse($kid->first, 6);
2050     }
2051     else {
2052         $first = $self->deparse($kid, 6);
2053     }
2054     if ($name eq "chmod" && $first =~ /^\d+$/) {
2055         $first = sprintf("%#o", $first);
2056     }
2057     $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
2058     push @exprs, $first;
2059     $kid = $kid->sibling;
2060     for (; !null($kid); $kid = $kid->sibling) {
2061         push @exprs, $self->deparse($kid, 6);
2062     }
2063     if ($parens) {
2064         return "$name(" . join(", ", @exprs) . ")";
2065     } else {
2066         return "$name " . join(", ", @exprs);
2067     }
2068 }
2069
2070 sub pp_bless { listop(@_, "bless") }
2071 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
2072 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
2073 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
2074 sub pp_index { maybe_targmy(@_, \&listop, "index") }
2075 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
2076 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
2077 sub pp_formline { listop(@_, "formline") } # see also deparse_format
2078 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
2079 sub pp_unpack { listop(@_, "unpack") }
2080 sub pp_pack { listop(@_, "pack") }
2081 sub pp_join { maybe_targmy(@_, \&listop, "join") }
2082 sub pp_splice { listop(@_, "splice") }
2083 sub pp_push { maybe_targmy(@_, \&listop, "push") }
2084 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
2085 sub pp_reverse { listop(@_, "reverse") }
2086 sub pp_warn { listop(@_, "warn") }
2087 sub pp_die { listop(@_, "die") }
2088 # Actually, return is exempt from the LLAFR (see examples in this very
2089 # module!), but for consistency's sake, ignore that fact
2090 sub pp_return { listop(@_, "return") }
2091 sub pp_open { listop(@_, "open") }
2092 sub pp_pipe_op { listop(@_, "pipe") }
2093 sub pp_tie { listop(@_, "tie") }
2094 sub pp_binmode { listop(@_, "binmode") }
2095 sub pp_dbmopen { listop(@_, "dbmopen") }
2096 sub pp_sselect { listop(@_, "select") }
2097 sub pp_select { listop(@_, "select") }
2098 sub pp_read { listop(@_, "read") }
2099 sub pp_sysopen { listop(@_, "sysopen") }
2100 sub pp_sysseek { listop(@_, "sysseek") }
2101 sub pp_sysread { listop(@_, "sysread") }
2102 sub pp_syswrite { listop(@_, "syswrite") }
2103 sub pp_send { listop(@_, "send") }
2104 sub pp_recv { listop(@_, "recv") }
2105 sub pp_seek { listop(@_, "seek") }
2106 sub pp_fcntl { listop(@_, "fcntl") }
2107 sub pp_ioctl { listop(@_, "ioctl") }
2108 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
2109 sub pp_socket { listop(@_, "socket") }
2110 sub pp_sockpair { listop(@_, "sockpair") }
2111 sub pp_bind { listop(@_, "bind") }
2112 sub pp_connect { listop(@_, "connect") }
2113 sub pp_listen { listop(@_, "listen") }
2114 sub pp_accept { listop(@_, "accept") }
2115 sub pp_shutdown { listop(@_, "shutdown") }
2116 sub pp_gsockopt { listop(@_, "getsockopt") }
2117 sub pp_ssockopt { listop(@_, "setsockopt") }
2118 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
2119 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
2120 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
2121 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
2122 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
2123 sub pp_link { maybe_targmy(@_, \&listop, "link") }
2124 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
2125 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
2126 sub pp_open_dir { listop(@_, "opendir") }
2127 sub pp_seekdir { listop(@_, "seekdir") }
2128 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
2129 sub pp_system { maybe_targmy(@_, \&listop, "system") }
2130 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
2131 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
2132 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
2133 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
2134 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
2135 sub pp_shmget { listop(@_, "shmget") }
2136 sub pp_shmctl { listop(@_, "shmctl") }
2137 sub pp_shmread { listop(@_, "shmread") }
2138 sub pp_shmwrite { listop(@_, "shmwrite") }
2139 sub pp_msgget { listop(@_, "msgget") }
2140 sub pp_msgctl { listop(@_, "msgctl") }
2141 sub pp_msgsnd { listop(@_, "msgsnd") }
2142 sub pp_msgrcv { listop(@_, "msgrcv") }
2143 sub pp_semget { listop(@_, "semget") }
2144 sub pp_semctl { listop(@_, "semctl") }
2145 sub pp_semop { listop(@_, "semop") }
2146 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
2147 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
2148 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
2149 sub pp_gsbyname { listop(@_, "getservbyname") }
2150 sub pp_gsbyport { listop(@_, "getservbyport") }
2151 sub pp_syscall { listop(@_, "syscall") }
2152
2153 sub pp_glob {
2154     my $self = shift;
2155     my($op, $cx) = @_;
2156     my $text = $self->dq($op->first->sibling);  # skip pushmark
2157     if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
2158         or $text =~ /[<>]/) {
2159         return 'glob(' . single_delim('qq', '"', $text) . ')';
2160     } else {
2161         return '<' . $text . '>';
2162     }
2163 }
2164
2165 # Truncate is special because OPf_SPECIAL makes a bareword first arg
2166 # be a filehandle. This could probably be better fixed in the core
2167 # by moving the GV lookup into ck_truc.
2168
2169 sub pp_truncate {
2170     my $self = shift;
2171     my($op, $cx) = @_;
2172     my(@exprs);
2173     my $parens = ($cx >= 5) || $self->{'parens'};
2174     my $kid = $op->first->sibling;
2175     my $fh;
2176     if ($op->flags & OPf_SPECIAL) {
2177         # $kid is an OP_CONST
2178         $fh = $self->const_sv($kid)->PV;
2179     } else {
2180         $fh = $self->deparse($kid, 6);
2181         $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
2182     }
2183     my $len = $self->deparse($kid->sibling, 6);
2184     if ($parens) {
2185         return "truncate($fh, $len)";
2186     } else {
2187         return "truncate $fh, $len";
2188     }
2189 }
2190
2191 sub indirop {
2192     my $self = shift;
2193     my($op, $cx, $name) = @_;
2194     my($expr, @exprs);
2195     my $kid = $op->first->sibling;
2196     my $indir = "";
2197     if ($op->flags & OPf_STACKED) {
2198         $indir = $kid;
2199         $indir = $indir->first; # skip rv2gv
2200         if (is_scope($indir)) {
2201             $indir = "{" . $self->deparse($indir, 0) . "}";
2202         } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
2203             $indir = $self->const_sv($indir)->PV;
2204         } else {
2205             $indir = $self->deparse($indir, 24);
2206         }
2207         $indir = $indir . " ";
2208         $kid = $kid->sibling;
2209     }
2210     if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
2211         $indir = ($op->private & OPpSORT_REVERSE) ? '{$b <=> $a} '
2212                                                   : '{$a <=> $b} ';
2213     }
2214     elsif ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
2215         $indir = '{$b cmp $a} ';
2216     }
2217     for (; !null($kid); $kid = $kid->sibling) {
2218         $expr = $self->deparse($kid, 6);
2219         push @exprs, $expr;
2220     }
2221     return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
2222                                     $cx, 5);
2223 }
2224
2225 sub pp_prtf { indirop(@_, "printf") }
2226 sub pp_print { indirop(@_, "print") }
2227 sub pp_sort { indirop(@_, "sort") }
2228
2229 sub mapop {
2230     my $self = shift;
2231     my($op, $cx, $name) = @_;
2232     my($expr, @exprs);
2233     my $kid = $op->first; # this is the (map|grep)start
2234     $kid = $kid->first->sibling; # skip a pushmark
2235     my $code = $kid->first; # skip a null
2236     if (is_scope $code) {
2237         $code = "{" . $self->deparse($code, 0) . "} ";
2238     } else {
2239         $code = $self->deparse($code, 24) . ", ";
2240     }
2241     $kid = $kid->sibling;
2242     for (; !null($kid); $kid = $kid->sibling) {
2243         $expr = $self->deparse($kid, 6);
2244         push @exprs, $expr if $expr;
2245     }
2246     return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2247 }
2248
2249 sub pp_mapwhile { mapop(@_, "map") }
2250 sub pp_grepwhile { mapop(@_, "grep") }
2251
2252 sub pp_list {
2253     my $self = shift;
2254     my($op, $cx) = @_;
2255     my($expr, @exprs);
2256     my $kid = $op->first->sibling; # skip pushmark
2257     my $lop;
2258     my $local = "either"; # could be local(...), my(...) or our(...)
2259     for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2260         # This assumes that no other private flags equal 128, and that
2261         # OPs that store things other than flags in their op_private,
2262         # like OP_AELEMFAST, won't be immediate children of a list.
2263         #
2264         # OP_ENTERSUB can break this logic, so check for it.
2265         # I suspect that open and exit can too.
2266
2267         if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
2268                 or $lop->name eq "undef")
2269             or $lop->name eq "entersub"
2270             or $lop->name eq "exit"
2271             or $lop->name eq "open")
2272         {
2273             $local = ""; # or not
2274             last;
2275         }
2276         if ($lop->name =~ /^pad[ash]v$/) { # my()
2277             ($local = "", last) if $local eq "local" || $local eq "our";
2278             $local = "my";
2279         } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
2280                         && $lop->private & OPpOUR_INTRO
2281                 or $lop->name eq "null" && $lop->first->name eq "gvsv"
2282                         && $lop->first->private & OPpOUR_INTRO) { # our()
2283             ($local = "", last) if $local eq "my" || $local eq "local";
2284             $local = "our";
2285         } elsif ($lop->name ne "undef") { # local()
2286             ($local = "", last) if $local eq "my" || $local eq "our";
2287             $local = "local";
2288         }
2289     }
2290     $local = "" if $local eq "either"; # no point if it's all undefs
2291     return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2292     for (; !null($kid); $kid = $kid->sibling) {
2293         if ($local) {
2294             if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2295                 $lop = $kid->first;
2296             } else {
2297                 $lop = $kid;
2298             }
2299             $self->{'avoid_local'}{$$lop}++;
2300             $expr = $self->deparse($kid, 6);
2301             delete $self->{'avoid_local'}{$$lop};
2302         } else {
2303             $expr = $self->deparse($kid, 6);
2304         }
2305         push @exprs, $expr;
2306     }
2307     if ($local) {
2308         return "$local(" . join(", ", @exprs) . ")";
2309     } else {
2310         return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2311     }
2312 }
2313
2314 sub is_ifelse_cont {
2315     my $op = shift;
2316     return ($op->name eq "null" and class($op) eq "UNOP"
2317             and $op->first->name =~ /^(and|cond_expr)$/
2318             and is_scope($op->first->first->sibling));
2319 }
2320
2321 sub pp_cond_expr {
2322     my $self = shift;
2323     my($op, $cx) = @_;
2324     my $cond = $op->first;
2325     my $true = $cond->sibling;
2326     my $false = $true->sibling;
2327     my $cuddle = $self->{'cuddle'};
2328     unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
2329             (is_scope($false) || is_ifelse_cont($false))
2330             and $self->{'expand'} < 7) {
2331         $cond = $self->deparse($cond, 8);
2332         $true = $self->deparse($true, 8);
2333         $false = $self->deparse($false, 8);
2334         return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2335     }
2336
2337     $cond = $self->deparse($cond, 1);
2338     $true = $self->deparse($true, 0);
2339     my $head = "if ($cond) {\n\t$true\n\b}";
2340     my @elsifs;
2341     while (!null($false) and is_ifelse_cont($false)) {
2342         my $newop = $false->first;
2343         my $newcond = $newop->first;
2344         my $newtrue = $newcond->sibling;
2345         $false = $newtrue->sibling; # last in chain is OP_AND => no else
2346         $newcond = $self->deparse($newcond, 1);
2347         $newtrue = $self->deparse($newtrue, 0);
2348         push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2349     }
2350     if (!null($false)) {
2351         $false = $cuddle . "else {\n\t" .
2352           $self->deparse($false, 0) . "\n\b}\cK";
2353     } else {
2354         $false = "\cK";
2355     }
2356     return $head . join($cuddle, "", @elsifs) . $false;
2357 }
2358
2359 sub loop_common {
2360     my $self = shift;
2361     my($op, $cx, $init) = @_;
2362     my $enter = $op->first;
2363     my $kid = $enter->sibling;
2364     local(@$self{qw'curstash warnings hints'})
2365                 = @$self{qw'curstash warnings hints'};
2366     my $head = "";
2367     my $bare = 0;
2368     my $body;
2369     my $cond = undef;
2370     if ($kid->name eq "lineseq") { # bare or infinite loop
2371         if (is_state $kid->last) { # infinite
2372             $head = "while (1) "; # Can't use for(;;) if there's a continue
2373             $cond = "";
2374         } else {
2375             $bare = 1;
2376         }
2377         $body = $kid;
2378     } elsif ($enter->name eq "enteriter") { # foreach
2379         my $ary = $enter->first->sibling; # first was pushmark
2380         my $var = $ary->sibling;
2381         if ($enter->flags & OPf_STACKED
2382             and not null $ary->first->sibling->sibling)
2383         {
2384             $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2385               $self->deparse($ary->first->sibling->sibling, 9);
2386         } else {
2387             $ary = $self->deparse($ary, 1);
2388         }
2389         if (null $var) {
2390             if ($enter->flags & OPf_SPECIAL) { # thread special var
2391                 $var = $self->pp_threadsv($enter, 1);
2392             } else { # regular my() variable
2393                 $var = $self->pp_padsv($enter, 1);
2394                 if ($self->padname_sv($enter->targ)->IVX ==
2395                     $kid->first->first->sibling->last->cop_seq)
2396                 {
2397                     # If the scope of this variable closes at the last
2398                     # statement of the loop, it must have been
2399                     # declared here.
2400                     $var = "my " . $var;
2401                 }
2402             }
2403         } elsif ($var->name eq "rv2gv") {
2404             $var = $self->pp_rv2sv($var, 1);
2405         } elsif ($var->name eq "gv") {
2406             $var = "\$" . $self->deparse($var, 1);
2407         }
2408         $head = "foreach $var ($ary) ";
2409         $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2410     } elsif ($kid->name eq "null") { # while/until
2411         $kid = $kid->first;
2412         my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2413         $cond = $self->deparse($kid->first, 1);
2414         $head = "$name ($cond) ";
2415         $body = $kid->first->sibling;
2416     } elsif ($kid->name eq "stub") { # bare and empty
2417         return "{;}"; # {} could be a hashref
2418     }
2419     # If there isn't a continue block, then the next pointer for the loop
2420     # will point to the unstack, which is kid's penultimate child, except
2421     # in a bare loop, when it will point to the leaveloop. When neither of
2422     # these conditions hold, then the third-to-last child in the continue
2423     # block (or the last in a bare loop).
2424     my $cont_start = $enter->nextop;
2425     my $cont;
2426     if ($$cont_start != $$op && ${$cont_start->sibling} != ${$body->last}) {
2427         if ($bare) {
2428             $cont = $body->last;
2429         } else {
2430             $cont = $body->first;
2431             while (!null($cont->sibling->sibling->sibling)) {
2432                 $cont = $cont->sibling;
2433             }
2434         }
2435         my $state = $body->first;
2436         my $cuddle = $self->{'cuddle'};
2437         my @states;
2438         for (; $$state != $$cont; $state = $state->sibling) {
2439             push @states, $state;
2440         }
2441         $body = $self->lineseq(undef, @states);
2442         if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2443             $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2444             $cont = "\cK";
2445         } else {
2446             $cont = $cuddle . "continue {\n\t" .
2447               $self->deparse($cont, 0) . "\n\b}\cK";
2448         }
2449     } else {
2450         return "" if !defined $body;
2451         if (length $init) {
2452             $head = "for ($init; $cond;) ";
2453         }
2454         $cont = "\cK";
2455         $body = $self->deparse($body, 0);
2456     }
2457     $body =~ s/;?$/;\n/;
2458
2459     return $head . "{\n\t" . $body . "\b}" . $cont;
2460 }
2461
2462 sub pp_leaveloop { loop_common(@_, "") }
2463
2464 sub for_loop {
2465     my $self = shift;
2466     my($op, $cx) = @_;
2467     my $init = $self->deparse($op, 1);
2468     return $self->loop_common($op->sibling->first->sibling, $cx, $init);
2469 }
2470
2471 sub pp_leavetry {
2472     my $self = shift;
2473     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2474 }
2475
2476 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2477 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2478 BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
2479 BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
2480
2481 sub pp_null {
2482     my $self = shift;
2483     my($op, $cx) = @_;
2484     if (class($op) eq "OP") {
2485         # old value is lost
2486         return $self->{'ex_const'} if $op->targ == OP_CONST;
2487     } elsif ($op->first->name eq "pushmark") {
2488         return $self->pp_list($op, $cx);
2489     } elsif ($op->first->name eq "enter") {
2490         return $self->pp_leave($op, $cx);
2491     } elsif ($op->targ == OP_STRINGIFY) {
2492         return $self->dquote($op, $cx);
2493     } elsif (!null($op->first->sibling) and
2494              $op->first->sibling->name eq "readline" and
2495              $op->first->sibling->flags & OPf_STACKED) {
2496         return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2497                                    . $self->deparse($op->first->sibling, 7),
2498                                    $cx, 7);
2499     } elsif (!null($op->first->sibling) and
2500              $op->first->sibling->name eq "trans" and
2501              $op->first->sibling->flags & OPf_STACKED) {
2502         return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2503                                    . $self->deparse($op->first->sibling, 20),
2504                                    $cx, 20);
2505     } elsif ($op->flags & OPf_SPECIAL && $cx == 0 && !$op->targ) {
2506         return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
2507     } elsif (!null($op->first->sibling) and
2508              $op->first->sibling->name eq "null" and
2509              class($op->first->sibling) eq "UNOP" and
2510              $op->first->sibling->first->flags & OPf_STACKED and
2511              $op->first->sibling->first->name eq "rcatline") {
2512         return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
2513                                    . $self->deparse($op->first->sibling, 18),
2514                                    $cx, 18);
2515     } else {
2516         return $self->deparse($op->first, $cx);
2517     }
2518 }
2519
2520 sub padname {
2521     my $self = shift;
2522     my $targ = shift;
2523     return $self->padname_sv($targ)->PVX;
2524 }
2525
2526 sub padany {
2527     my $self = shift;
2528     my $op = shift;
2529     return substr($self->padname($op->targ), 1); # skip $/@/%
2530 }
2531
2532 sub pp_padsv {
2533     my $self = shift;
2534     my($op, $cx) = @_;
2535     return $self->maybe_my($op, $cx, $self->padname($op->targ));
2536 }
2537
2538 sub pp_padav { pp_padsv(@_) }
2539 sub pp_padhv { pp_padsv(@_) }
2540
2541 my @threadsv_names;
2542
2543 BEGIN {
2544     @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2545                        "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2546                        "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2547                        "!", "@");
2548 }
2549
2550 sub pp_threadsv {
2551     my $self = shift;
2552     my($op, $cx) = @_;
2553     return $self->maybe_local($op, $cx, "\$" .  $threadsv_names[$op->targ]);
2554 }
2555
2556 sub gv_or_padgv {
2557     my $self = shift;
2558     my $op = shift;
2559     if (class($op) eq "PADOP") {
2560         return $self->padval($op->padix);
2561     } else { # class($op) eq "SVOP"
2562         return $op->gv;
2563     }
2564 }
2565
2566 sub pp_gvsv {
2567     my $self = shift;
2568     my($op, $cx) = @_;
2569     my $gv = $self->gv_or_padgv($op);
2570     return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2571                                  $self->gv_name($gv)));
2572 }
2573
2574 sub pp_gv {
2575     my $self = shift;
2576     my($op, $cx) = @_;
2577     my $gv = $self->gv_or_padgv($op);
2578     return $self->gv_name($gv);
2579 }
2580
2581 sub pp_aelemfast {
2582     my $self = shift;
2583     my($op, $cx) = @_;
2584     my $gv = $self->gv_or_padgv($op);
2585     my $name = $self->gv_name($gv);
2586     $name = $self->{'curstash'}."::$name"
2587         if $name !~ /::/ && $self->lex_in_scope('@'.$name);
2588
2589     return "\$" . $name . "[" .
2590                   ($op->private + $self->{'arybase'}) . "]";
2591 }
2592
2593 sub rv2x {
2594     my $self = shift;
2595     my($op, $cx, $type) = @_;
2596
2597     if (class($op) eq 'NULL' || !$op->can("first")) {
2598         Carp::cluck("Unexpected op in pp_rv2x");
2599         return 'XXX';
2600     }
2601     my $kid = $op->first;
2602     my $str = $self->deparse($kid, 0);
2603     return $self->stash_variable($type, $str) if is_scalar($kid);
2604     return $type ."{$str}";
2605 }
2606
2607 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2608 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2609 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2610
2611 # skip rv2av
2612 sub pp_av2arylen {
2613     my $self = shift;
2614     my($op, $cx) = @_;
2615     if ($op->first->name eq "padav") {
2616         return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2617     } else {
2618         return $self->maybe_local($op, $cx,
2619                                   $self->rv2x($op->first, $cx, '$#'));
2620     }
2621 }
2622
2623 # skip down to the old, ex-rv2cv
2624 sub pp_rv2cv {
2625     my ($self, $op, $cx) = @_;
2626     if (!null($op->first) && $op->first->name eq 'null' &&
2627         $op->first->targ eq OP_LIST)
2628     {
2629         return $self->rv2x($op->first->first->sibling, $cx, "&")
2630     }
2631     else {
2632         return $self->rv2x($op, $cx, "")
2633     }
2634 }
2635
2636 sub pp_rv2av {
2637     my $self = shift;
2638     my($op, $cx) = @_;
2639     my $kid = $op->first;
2640     if ($kid->name eq "const") { # constant list
2641         my $av = $self->const_sv($kid);
2642         return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2643     } else {
2644         return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2645     }
2646  }
2647
2648 sub is_subscriptable {
2649     my $op = shift;
2650     if ($op->name =~ /^[ahg]elem/) {
2651         return 1;
2652     } elsif ($op->name eq "entersub") {
2653         my $kid = $op->first;
2654         return 0 unless null $kid->sibling;
2655         $kid = $kid->first;
2656         $kid = $kid->sibling until null $kid->sibling;
2657         return 0 if is_scope($kid);
2658         $kid = $kid->first;
2659         return 0 if $kid->name eq "gv";
2660         return 0 if is_scalar($kid);
2661         return is_subscriptable($kid);
2662     } else {
2663         return 0;
2664     }
2665 }
2666
2667 sub elem {
2668     my $self = shift;
2669     my ($op, $cx, $left, $right, $padname) = @_;
2670     my($array, $idx) = ($op->first, $op->first->sibling);
2671     unless ($array->name eq $padname) { # Maybe this has been fixed
2672         $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2673     }
2674     if ($array->name eq $padname) {
2675         $array = $self->padany($array);
2676     } elsif (is_scope($array)) { # ${expr}[0]
2677         $array = "{" . $self->deparse($array, 0) . "}";
2678     } elsif ($array->name eq "gv") {
2679         $array = $self->gv_name($self->gv_or_padgv($array));
2680         if ($array !~ /::/) {
2681             my $prefix = ($left eq '[' ? '@' : '%');
2682             $array = $self->{curstash}.'::'.$array
2683                 if $self->lex_in_scope($prefix . $array);
2684         }
2685     } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2686         $array = $self->deparse($array, 24);
2687     } else {
2688         # $x[20][3]{hi} or expr->[20]
2689         my $arrow = is_subscriptable($array) ? "" : "->";
2690         return $self->deparse($array, 24) . $arrow .
2691             $left . $self->deparse($idx, 1) . $right;
2692     }
2693     $idx = $self->deparse($idx, 1);
2694
2695     # Outer parens in an array index will confuse perl
2696     # if we're interpolating in a regular expression, i.e.
2697     # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2698     #
2699     # If $self->{parens}, then an initial '(' will
2700     # definitely be paired with a final ')'. If
2701     # !$self->{parens}, the misleading parens won't
2702     # have been added in the first place.
2703     #
2704     # [You might think that we could get "(...)...(...)"
2705     # where the initial and final parens do not match
2706     # each other. But we can't, because the above would
2707     # only happen if there's an infix binop between the
2708     # two pairs of parens, and *that* means that the whole
2709     # expression would be parenthesized as well.]
2710     #
2711     $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2712
2713     # Hash-element braces will autoquote a bareword inside themselves.
2714     # We need to make sure that C<$hash{warn()}> doesn't come out as
2715     # C<$hash{warn}>, which has a quite different meaning. Currently
2716     # B::Deparse will always quote strings, even if the string was a
2717     # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
2718     # for constant strings.) So we can cheat slightly here - if we see
2719     # a bareword, we know that it is supposed to be a function call.
2720     #
2721     $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
2722
2723     return "\$" . $array . $left . $idx . $right;
2724 }
2725
2726 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2727 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2728
2729 sub pp_gelem {
2730     my $self = shift;
2731     my($op, $cx) = @_;
2732     my($glob, $part) = ($op->first, $op->last);
2733     $glob = $glob->first; # skip rv2gv
2734     $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2735     my $scope = is_scope($glob);
2736     $glob = $self->deparse($glob, 0);
2737     $part = $self->deparse($part, 1);
2738     return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2739 }
2740
2741 sub slice {
2742     my $self = shift;
2743     my ($op, $cx, $left, $right, $regname, $padname) = @_;
2744     my $last;
2745     my(@elems, $kid, $array, $list);
2746     if (class($op) eq "LISTOP") {
2747         $last = $op->last;
2748     } else { # ex-hslice inside delete()
2749         for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2750         $last = $kid;
2751     }
2752     $array = $last;
2753     $array = $array->first
2754         if $array->name eq $regname or $array->name eq "null";
2755     if (is_scope($array)) {
2756         $array = "{" . $self->deparse($array, 0) . "}";
2757     } elsif ($array->name eq $padname) {
2758         $array = $self->padany($array);
2759     } else {
2760         $array = $self->deparse($array, 24);
2761     }
2762     $kid = $op->first->sibling; # skip pushmark
2763     if ($kid->name eq "list") {
2764         $kid = $kid->first->sibling; # skip list, pushmark
2765         for (; !null $kid; $kid = $kid->sibling) {
2766             push @elems, $self->deparse($kid, 6);
2767         }
2768         $list = join(", ", @elems);
2769     } else {
2770         $list = $self->deparse($kid, 1);
2771     }
2772     return "\@" . $array . $left . $list . $right;
2773 }
2774
2775 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2776 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2777
2778 sub pp_lslice {
2779     my $self = shift;
2780     my($op, $cx) = @_;
2781     my $idx = $op->first;
2782     my $list = $op->last;
2783     my(@elems, $kid);
2784     $list = $self->deparse($list, 1);
2785     $idx = $self->deparse($idx, 1);
2786     return "($list)" . "[$idx]";
2787 }
2788
2789 sub want_scalar {
2790     my $op = shift;
2791     return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2792 }
2793
2794 sub want_list {
2795     my $op = shift;
2796     return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2797 }
2798
2799 sub method {
2800     my $self = shift;
2801     my($op, $cx) = @_;
2802     my $kid = $op->first->sibling; # skip pushmark
2803     my($meth, $obj, @exprs);
2804     if ($kid->name eq "list" and want_list $kid) {
2805         # When an indirect object isn't a bareword but the args are in
2806         # parens, the parens aren't part of the method syntax (the LLAFR
2807         # doesn't apply), but they make a list with OPf_PARENS set that
2808         # doesn't get flattened by the append_elem that adds the method,
2809         # making a (object, arg1, arg2, ...) list where the object
2810         # usually is. This can be distinguished from
2811         # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2812         # object) because in the later the list is in scalar context
2813         # as the left side of -> always is, while in the former
2814         # the list is in list context as method arguments always are.
2815         # (Good thing there aren't method prototypes!)
2816         $meth = $kid->sibling;
2817         $kid = $kid->first->sibling; # skip pushmark
2818         $obj = $kid;
2819         $kid = $kid->sibling;
2820         for (; not null $kid; $kid = $kid->sibling) {
2821             push @exprs, $self->deparse($kid, 6);
2822         }
2823     } else {
2824         $obj = $kid;
2825         $kid = $kid->sibling;
2826         for (; !null ($kid->sibling) && $kid->name ne "method_named";
2827               $kid = $kid->sibling) {
2828             push @exprs, $self->deparse($kid, 6);
2829         }
2830         $meth = $kid;
2831     }
2832     $obj = $self->deparse($obj, 24);
2833     if ($meth->name eq "method_named") {
2834         $meth = $self->const_sv($meth)->PV;
2835     } else {
2836         $meth = $meth->first;
2837         if ($meth->name eq "const") {
2838             # As of 5.005_58, this case is probably obsoleted by the
2839             # method_named case above
2840             $meth = $self->const_sv($meth)->PV; # needs to be bare
2841         } else {
2842             $meth = $self->deparse($meth, 1);
2843         }
2844     }
2845     my $args = join(", ", @exprs);
2846     $kid = $obj . "->" . $meth;
2847     if (length $args) {
2848         return $kid . "(" . $args . ")"; # parens mandatory
2849     } else {
2850         return $kid;
2851     }
2852 }
2853
2854 # returns "&" if the prototype doesn't match the args,
2855 # or ("", $args_after_prototype_demunging) if it does.
2856 sub check_proto {
2857     my $self = shift;
2858     my($proto, @args) = @_;
2859     my($arg, $real);
2860     my $doneok = 0;
2861     my @reals;
2862     # An unbackslashed @ or % gobbles up the rest of the args
2863     $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2864     while ($proto) {
2865         $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2866         my $chr = $1;
2867         if ($chr eq "") {
2868             return "&" if @args;
2869         } elsif ($chr eq ";") {
2870             $doneok = 1;
2871         } elsif ($chr eq "@" or $chr eq "%") {
2872             push @reals, map($self->deparse($_, 6), @args);
2873             @args = ();
2874         } else {
2875             $arg = shift @args;
2876             last unless $arg;
2877             if ($chr eq "\$") {
2878                 if (want_scalar $arg) {
2879                     push @reals, $self->deparse($arg, 6);
2880                 } else {
2881                     return "&";
2882                 }
2883             } elsif ($chr eq "&") {
2884                 if ($arg->name =~ /^(s?refgen|undef)$/) {
2885                     push @reals, $self->deparse($arg, 6);
2886                 } else {
2887                     return "&";
2888                 }
2889             } elsif ($chr eq "*") {
2890                 if ($arg->name =~ /^s?refgen$/
2891                     and $arg->first->first->name eq "rv2gv")
2892                   {
2893                       $real = $arg->first->first; # skip refgen, null
2894                       if ($real->first->name eq "gv") {
2895                           push @reals, $self->deparse($real, 6);
2896                       } else {
2897                           push @reals, $self->deparse($real->first, 6);
2898                       }
2899                   } else {
2900                       return "&";
2901                   }
2902             } elsif (substr($chr, 0, 1) eq "\\") {
2903                 $chr = substr($chr, 1);
2904                 if ($arg->name =~ /^s?refgen$/ and
2905                     !null($real = $arg->first) and
2906                     ($chr eq "\$" && is_scalar($real->first)
2907                      or ($chr eq "\@"
2908                          && $real->first->sibling->name
2909                          =~ /^(rv2|pad)av$/)
2910                      or ($chr eq "%"
2911                          && $real->first->sibling->name
2912                          =~ /^(rv2|pad)hv$/)
2913                      #or ($chr eq "&" # This doesn't work
2914                      #   && $real->first->name eq "rv2cv")
2915                      or ($chr eq "*"
2916                          && $real->first->name eq "rv2gv")))
2917                   {
2918                       push @reals, $self->deparse($real, 6);
2919                   } else {
2920                       return "&";
2921                   }
2922             }
2923        }
2924     }
2925     return "&" if $proto and !$doneok; # too few args and no `;'
2926     return "&" if @args;               # too many args
2927     return ("", join ", ", @reals);
2928 }
2929
2930 sub pp_entersub {
2931     my $self = shift;
2932     my($op, $cx) = @_;
2933     return $self->method($op, $cx) unless null $op->first->sibling;
2934     my $prefix = "";
2935     my $amper = "";
2936     my($kid, @exprs);
2937     if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
2938         $prefix = "do ";
2939     } elsif ($op->private & OPpENTERSUB_AMPER) {
2940         $amper = "&";
2941     }
2942     $kid = $op->first;
2943     $kid = $kid->first->sibling; # skip ex-list, pushmark
2944     for (; not null $kid->sibling; $kid = $kid->sibling) {
2945         push @exprs, $kid;
2946     }
2947     my $simple = 0;
2948     my $proto = undef;
2949     if (is_scope($kid)) {
2950         $amper = "&";
2951         $kid = "{" . $self->deparse($kid, 0) . "}";
2952     } elsif ($kid->first->name eq "gv") {
2953         my $gv = $self->gv_or_padgv($kid->first);
2954         if (class($gv->CV) ne "SPECIAL") {
2955             $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2956         }
2957         $simple = 1; # only calls of named functions can be prototyped
2958         $kid = $self->deparse($kid, 24);
2959     } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
2960         $amper = "&";
2961         $kid = $self->deparse($kid, 24);
2962     } else {
2963         $prefix = "";
2964         my $arrow = is_subscriptable($kid->first) ? "" : "->";
2965         $kid = $self->deparse($kid, 24) . $arrow;
2966     }
2967
2968     # Doesn't matter how many prototypes there are, if
2969     # they haven't happened yet!
2970     my $declared;
2971     {
2972         no strict 'refs';
2973         no warnings 'uninitialized';
2974         $declared = exists $self->{'subs_declared'}{$kid}
2975             || (
2976                  defined &{ %{$self->{'curstash'}."::"}->{$kid} }
2977                  && !exists
2978                      $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
2979                  && defined prototype $self->{'curstash'}."::".$kid
2980                );
2981         if (!$declared && defined($proto)) {
2982             # Avoid "too early to check prototype" warning
2983             ($amper, $proto) = ('&');
2984         }
2985     }
2986
2987     my $args;
2988     if ($declared and defined $proto and not $amper) {
2989         ($amper, $args) = $self->check_proto($proto, @exprs);
2990         if ($amper eq "&") {
2991             $args = join(", ", map($self->deparse($_, 6), @exprs));
2992         }
2993     } else {
2994         $args = join(", ", map($self->deparse($_, 6), @exprs));
2995     }
2996     if ($prefix or $amper) {
2997         if ($op->flags & OPf_STACKED) {
2998             return $prefix . $amper . $kid . "(" . $args . ")";
2999         } else {
3000             return $prefix . $amper. $kid;
3001         }
3002     } else {
3003         # glob() invocations can be translated into calls of
3004         # CORE::GLOBAL::glob with a second parameter, a number.
3005         # Reverse this.
3006         if ($kid eq "CORE::GLOBAL::glob") {
3007             $kid = "glob";
3008             $args =~ s/\s*,[^,]+$//;
3009         }
3010
3011         # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
3012         # so it must have been translated from a keyword call. Translate
3013         # it back.
3014         $kid =~ s/^CORE::GLOBAL:://;
3015
3016         if (!$declared) {
3017             return "$kid(" . $args . ")";
3018         } elsif (defined $proto and $proto eq "") {
3019             return $kid;
3020         } elsif (defined $proto and $proto eq "\$" and is_scalar($exprs[0])) {
3021             return $self->maybe_parens_func($kid, $args, $cx, 16);
3022         } elsif (defined($proto) && $proto or $simple) {
3023             return $self->maybe_parens_func($kid, $args, $cx, 5);
3024         } else {
3025             return "$kid(" . $args . ")";
3026         }
3027     }
3028 }
3029
3030 sub pp_enterwrite { unop(@_, "write") }
3031
3032 # escape things that cause interpolation in double quotes,
3033 # but not character escapes
3034 sub uninterp {
3035     my($str) = @_;
3036     $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
3037     return $str;
3038 }
3039
3040 {
3041 my $bal;
3042 BEGIN {
3043     use re "eval";
3044     # Matches any string which is balanced with respect to {braces}
3045     $bal = qr(
3046       (?:
3047         [^\\{}]
3048       | \\\\
3049       | \\[{}]
3050       | \{(??{$bal})\}
3051       )*
3052     )x;
3053 }
3054
3055 # the same, but treat $|, $), $( and $ at the end of the string differently
3056 sub re_uninterp {
3057     my($str) = @_;
3058
3059     $str =~ s/
3060           ( ^|\G                  # $1
3061           | [^\\]
3062           )
3063
3064           (                       # $2
3065             (?:\\\\)*
3066           )
3067
3068           (                       # $3
3069             (\(\?\??\{$bal\}\))   # $4
3070           | [\$\@]
3071             (?!\||\)|\(|$)
3072           | \\[uUlLQE]
3073           )
3074
3075         /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3076
3077     return $str;
3078 }
3079
3080 # This is for regular expressions with the /x modifier
3081 # We have to leave comments unmangled.
3082 sub re_uninterp_extended {
3083     my($str) = @_;
3084
3085     $str =~ s/
3086           ( ^|\G                  # $1
3087           | [^\\]
3088           )
3089
3090           (                       # $2
3091             (?:\\\\)*
3092           )
3093
3094           (                       # $3
3095             ( \(\?\??\{$bal\}\)   # $4  (skip over (?{}) and (??{}) blocks)
3096             | \#[^\n]*            #     (skip over comments)
3097             )
3098           | [\$\@]
3099             (?!\||\)|\(|$)
3100           | \\[uUlLQE]
3101           )
3102
3103         /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3104
3105     return $str;
3106 }
3107 }
3108
3109 # character escapes, but not delimiters that might need to be escaped
3110 sub escape_str { # ASCII, UTF8
3111     my($str) = @_;
3112     $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3113     $str =~ s/\a/\\a/g;
3114 #    $str =~ s/\cH/\\b/g; # \b means someting different in a regex
3115     $str =~ s/\t/\\t/g;
3116     $str =~ s/\n/\\n/g;
3117     $str =~ s/\e/\\e/g;
3118     $str =~ s/\f/\\f/g;
3119     $str =~ s/\r/\\r/g;
3120     $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
3121     $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
3122     return $str;
3123 }
3124
3125 # For regexes with the /x modifier.
3126 # Leave whitespace unmangled.
3127 sub escape_extended_re {
3128     my($str) = @_;
3129     $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3130     $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
3131     $str =~ s/\n/\n\f/g;
3132     return $str;
3133 }
3134
3135 # Don't do this for regexen
3136 sub unback {
3137     my($str) = @_;
3138     $str =~ s/\\/\\\\/g;
3139     return $str;
3140 }
3141
3142 # Remove backslashes which precede literal control characters,
3143 # to avoid creating ambiguity when we escape the latter.
3144 sub re_unback {
3145     my($str) = @_;
3146
3147     # the insane complexity here is due to the behaviour of "\c\"
3148     $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
3149     return $str;
3150 }
3151
3152 sub balanced_delim {
3153     my($str) = @_;
3154     my @str = split //, $str;
3155     my($ar, $open, $close, $fail, $c, $cnt);
3156     for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
3157         ($open, $close) = @$ar;
3158         $fail = 0; $cnt = 0;
3159         for $c (@str) {
3160             if ($c eq $open) {
3161                 $cnt++;
3162             } elsif ($c eq $close) {
3163                 $cnt--;
3164                 if ($cnt < 0) {
3165                     # qq()() isn't ")("
3166                     $fail = 1;
3167                     last;
3168                 }
3169             }
3170         }
3171         $fail = 1 if $cnt != 0;
3172         return ($open, "$open$str$close") if not $fail;
3173     }
3174     return ("", $str);
3175 }
3176
3177 sub single_delim {
3178     my($q, $default, $str) = @_;
3179     return "$default$str$default" if $default and index($str, $default) == -1;
3180     if ($q ne 'qr') {
3181         (my $succeed, $str) = balanced_delim($str);
3182         return "$q$str" if $succeed;
3183     }
3184     for my $delim ('/', '"', '#') {
3185         return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3186     }
3187     if ($default) {
3188         $str =~ s/$default/\\$default/g;
3189         return "$default$str$default";
3190     } else {
3191         $str =~ s[/][\\/]g;
3192         return "$q/$str/";
3193     }
3194 }
3195
3196 sub const {
3197     my $sv = shift;
3198     if (class($sv) eq "SPECIAL") {
3199         return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
3200     } elsif (class($sv) eq "NULL") {
3201        return 'undef';
3202     } elsif ($sv->FLAGS & SVf_IOK) {
3203         return $sv->int_value;
3204     } elsif ($sv->FLAGS & SVf_NOK) {
3205         # try the default stringification
3206         my $r = "".$sv->NV;
3207         if ($r =~ /e/) {
3208             # If it's in scientific notation, we might have lost information
3209             return sprintf("%.20e", $sv->NV);
3210         }
3211         return $r;
3212     } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3213         return "\\(" . const($sv->RV) . ")"; # constant folded
3214     } elsif ($sv->FLAGS & SVf_POK) {
3215         my $str = $sv->PV;
3216         if ($str =~ /[^ -~]/) { # ASCII for non-printing
3217             return single_delim("qq", '"', uninterp escape_str unback $str);
3218         } else {
3219             return single_delim("q", "'", unback $str);
3220         }
3221     } else {
3222         return "undef";
3223     }
3224 }
3225
3226 sub const_sv {
3227     my $self = shift;
3228     my $op = shift;
3229     my $sv = $op->sv;
3230     # the constant could be in the pad (under useithreads)
3231     $sv = $self->padval($op->targ) unless $$sv;
3232     return $sv;
3233 }
3234
3235 sub pp_const {
3236     my $self = shift;
3237     my($op, $cx) = @_;
3238     if ($op->private & OPpCONST_ARYBASE) {
3239         return '$[';
3240     }
3241 #    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3242 #       return $self->const_sv($op)->PV;
3243 #    }
3244     my $sv = $self->const_sv($op);
3245 #    return const($sv);
3246     my $c = const $sv;
3247     return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
3248 }
3249
3250 sub dq {
3251     my $self = shift;
3252     my $op = shift;
3253     my $type = $op->name;
3254     if ($type eq "const") {
3255         return '$[' if $op->private & OPpCONST_ARYBASE;
3256         return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3257     } elsif ($type eq "concat") {
3258         my $first = $self->dq($op->first);
3259         my $last  = $self->dq($op->last);
3260
3261         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3262         ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3263             $first =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
3264             || ($last =~ /^[{\[\w_]/ &&
3265                 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3266
3267         return $first . $last;
3268     } elsif ($type eq "uc") {
3269         return '\U' . $self->dq($op->first->sibling) . '\E';
3270     } elsif ($type eq "lc") {
3271         return '\L' . $self->dq($op->first->sibling) . '\E';
3272     } elsif ($type eq "ucfirst") {
3273         return '\u' . $self->dq($op->first->sibling);
3274     } elsif ($type eq "lcfirst") {
3275         return '\l' . $self->dq($op->first->sibling);
3276     } elsif ($type eq "quotemeta") {
3277         return '\Q' . $self->dq($op->first->sibling) . '\E';
3278     } elsif ($type eq "join") {
3279         return $self->deparse($op->last, 26); # was join($", @ary)
3280     } else {
3281         return $self->deparse($op, 26);
3282     }
3283 }
3284
3285 sub pp_backtick {
3286     my $self = shift;
3287     my($op, $cx) = @_;
3288     # skip pushmark
3289     return single_delim("qx", '`', $self->dq($op->first->sibling));
3290 }
3291
3292 sub dquote {
3293     my $self = shift;
3294     my($op, $cx) = @_;
3295     my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3296     return $self->deparse($kid, $cx) if $self->{'unquote'};
3297     $self->maybe_targmy($kid, $cx,
3298                         sub {single_delim("qq", '"', $self->dq($_[1]))});
3299 }
3300
3301 # OP_STRINGIFY is a listop, but it only ever has one arg
3302 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3303
3304 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3305 # note that tr(from)/to/ is OK, but not tr/from/(to)
3306 sub double_delim {
3307     my($from, $to) = @_;
3308     my($succeed, $delim);
3309     if ($from !~ m[/] and $to !~ m[/]) {
3310         return "/$from/$to/";
3311     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3312         if (($succeed, $to) = balanced_delim($to) and $succeed) {
3313             return "$from$to";
3314         } else {
3315             for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3316                 return "$from$delim$to$delim" if index($to, $delim) == -1;
3317             }
3318             $to =~ s[/][\\/]g;
3319             return "$from/$to/";
3320         }
3321     } else {
3322         for $delim ('/', '"', '#') { # note no '
3323             return "$delim$from$delim$to$delim"
3324                 if index($to . $from, $delim) == -1;
3325         }
3326         $from =~ s[/][\\/]g;
3327         $to =~ s[/][\\/]g;
3328         return "/$from/$to/";
3329     }
3330 }
3331
3332 # Only used by tr///, so backslashes hyphens
3333 sub pchr { # ASCII
3334     my($n) = @_;
3335     if ($n == ord '\\') {
3336         return '\\\\';
3337     } elsif ($n == ord "-") {
3338         return "\\-";
3339     } elsif ($n >= ord(' ') and $n <= ord('~')) {
3340         return chr($n);
3341     } elsif ($n == ord "\a") {
3342         return '\\a';
3343     } elsif ($n == ord "\b") {
3344         return '\\b';
3345     } elsif ($n == ord "\t") {
3346         return '\\t';
3347     } elsif ($n == ord "\n") {
3348         return '\\n';
3349     } elsif ($n == ord "\e") {
3350         return '\\e';
3351     } elsif ($n == ord "\f") {
3352         return '\\f';
3353     } elsif ($n == ord "\r") {
3354         return '\\r';
3355     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3356         return '\\c' . chr(ord("@") + $n);
3357     } else {
3358 #       return '\x' . sprintf("%02x", $n);
3359         return '\\' . sprintf("%03o", $n);
3360     }
3361 }
3362
3363 sub collapse {
3364     my(@chars) = @_;
3365     my($str, $c, $tr) = ("");
3366     for ($c = 0; $c < @chars; $c++) {
3367         $tr = $chars[$c];
3368         $str .= pchr($tr);
3369         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3370             $chars[$c + 2] == $tr + 2)
3371         {
3372             for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3373               {}
3374             $str .= "-";
3375             $str .= pchr($chars[$c]);
3376         }
3377     }
3378     return $str;
3379 }
3380
3381 sub tr_decode_byte {
3382     my($table, $flags) = @_;
3383     my(@table) = unpack("s*", $table);
3384     splice @table, 0x100, 1;   # Number of subsequent elements
3385     my($c, $tr, @from, @to, @delfrom, $delhyphen);
3386     if ($table[ord "-"] != -1 and
3387         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3388     {
3389         $tr = $table[ord "-"];
3390         $table[ord "-"] = -1;
3391         if ($tr >= 0) {
3392             @from = ord("-");
3393             @to = $tr;
3394         } else { # -2 ==> delete
3395             $delhyphen = 1;
3396         }
3397     }
3398     for ($c = 0; $c < @table; $c++) {
3399         $tr = $table[$c];
3400         if ($tr >= 0) {
3401             push @from, $c; push @to, $tr;
3402         } elsif ($tr == -2) {
3403             push @delfrom, $c;
3404         }
3405     }
3406     @from = (@from, @delfrom);
3407     if ($flags & OPpTRANS_COMPLEMENT) {
3408         my @newfrom = ();
3409         my %from;
3410         @from{@from} = (1) x @from;
3411         for ($c = 0; $c < 256; $c++) {
3412             push @newfrom, $c unless $from{$c};
3413         }
3414         @from = @newfrom;
3415     }
3416     unless ($flags & OPpTRANS_DELETE || !@to) {
3417         pop @to while $#to and $to[$#to] == $to[$#to -1];
3418     }
3419     my($from, $to);
3420     $from = collapse(@from);
3421     $to = collapse(@to);
3422     $from .= "-" if $delhyphen;
3423     return ($from, $to);
3424 }
3425
3426 sub tr_chr {
3427     my $x = shift;
3428     if ($x == ord "-") {
3429         return "\\-";
3430     } elsif ($x == ord "\\") {
3431         return "\\\\";
3432     } else {
3433         return chr $x;
3434     }
3435 }
3436
3437 # XXX This doesn't yet handle all cases correctly either
3438
3439 sub tr_decode_utf8 {
3440     my($swash_hv, $flags) = @_;
3441     my %swash = $swash_hv->ARRAY;
3442     my $final = undef;
3443     $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3444     my $none = $swash{"NONE"}->IV;
3445     my $extra = $none + 1;
3446     my(@from, @delfrom, @to);
3447     my $line;
3448     foreach $line (split /\n/, $swash{'LIST'}->PV) {
3449         my($min, $max, $result) = split(/\t/, $line);
3450         $min = hex $min;
3451         if (length $max) {
3452             $max = hex $max;
3453         } else {
3454             $max = $min;
3455         }
3456         $result = hex $result;
3457         if ($result == $extra) {
3458             push @delfrom, [$min, $max];
3459         } else {
3460             push @from, [$min, $max];
3461             push @to, [$result, $result + $max - $min];
3462         }
3463     }
3464     for my $i (0 .. $#from) {
3465         if ($from[$i][0] == ord '-') {
3466             unshift @from, splice(@from, $i, 1);
3467             unshift @to, splice(@to, $i, 1);
3468             last;
3469         } elsif ($from[$i][1] == ord '-') {
3470             $from[$i][1]--;
3471             $to[$i][1]--;
3472             unshift @from, ord '-';
3473             unshift @to, ord '-';
3474             last;
3475         }
3476     }
3477     for my $i (0 .. $#delfrom) {
3478         if ($delfrom[$i][0] == ord '-') {
3479             push @delfrom, splice(@delfrom, $i, 1);
3480             last;
3481         } elsif ($delfrom[$i][1] == ord '-') {
3482             $delfrom[$i][1]--;
3483             push @delfrom, ord '-';
3484             last;
3485         }
3486     }
3487     if (defined $final and $to[$#to][1] != $final) {
3488         push @to, [$final, $final];
3489     }
3490     push @from, @delfrom;
3491     if ($flags & OPpTRANS_COMPLEMENT) {
3492         my @newfrom;
3493         my $next = 0;
3494         for my $i (0 .. $#from) {
3495             push @newfrom, [$next, $from[$i][0] - 1];
3496             $next = $from[$i][1] + 1;
3497         }
3498         @from = ();
3499         for my $range (@newfrom) {
3500             if ($range->[0] <= $range->[1]) {
3501                 push @from, $range;
3502             }
3503         }
3504     }
3505     my($from, $to, $diff);
3506     for my $chunk (@from) {
3507         $diff = $chunk->[1] - $chunk->[0];
3508         if ($diff > 1) {
3509             $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3510         } elsif ($diff == 1) {
3511             $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3512         } else {
3513             $from .= tr_chr($chunk->[0]);
3514         }
3515     }
3516     for my $chunk (@to) {
3517         $diff = $chunk->[1] - $chunk->[0];
3518         if ($diff > 1) {
3519             $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3520         } elsif ($diff == 1) {
3521             $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3522         } else {
3523             $to .= tr_chr($chunk->[0]);
3524         }
3525     }
3526     #$final = sprintf("%04x", $final) if defined $final;
3527     #$none = sprintf("%04x", $none) if defined $none;
3528     #$extra = sprintf("%04x", $extra) if defined $extra;
3529     #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3530     #print STDERR $swash{'LIST'}->PV;
3531     return (escape_str($from), escape_str($to));
3532 }
3533
3534 sub pp_trans {
3535     my $self = shift;
3536     my($op, $cx) = @_;
3537     my($from, $to);
3538     if (class($op) eq "PVOP") {
3539         ($from, $to) = tr_decode_byte($op->pv, $op->private);
3540     } else { # class($op) eq "SVOP"
3541         ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3542     }
3543     my $flags = "";
3544     $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3545     $flags .= "d" if $op->private & OPpTRANS_DELETE;
3546     $to = "" if $from eq $to and $flags eq "";
3547     $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3548     return "tr" . double_delim($from, $to) . $flags;
3549 }
3550
3551 # Like dq(), but different
3552 sub re_dq {
3553     my $self = shift;
3554     my ($op, $extended) = @_;
3555
3556     my $type = $op->name;
3557     if ($type eq "const") {
3558         return '$[' if $op->private & OPpCONST_ARYBASE;
3559         my $unbacked = re_unback($self->const_sv($op)->as_string);
3560         return re_uninterp_extended(escape_extended_re($unbacked))
3561             if $extended;
3562         return re_uninterp(escape_str($unbacked));
3563     } elsif ($type eq "concat") {
3564         my $first = $self->re_dq($op->first, $extended);
3565         my $last  = $self->re_dq($op->last,  $extended);
3566
3567         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3568         ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3569             $first =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
3570             || ($last =~ /^[{\[\w_]/ &&
3571                 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3572
3573         return $first . $last;
3574     } elsif ($type eq "uc") {
3575         return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
3576     } elsif ($type eq "lc") {
3577         return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
3578     } elsif ($type eq "ucfirst") {
3579         return '\u' . $self->re_dq($op->first->sibling, $extended);
3580     } elsif ($type eq "lcfirst") {
3581         return '\l' . $self->re_dq($op->first->sibling, $extended);
3582     } elsif ($type eq "quotemeta") {
3583         return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
3584     } elsif ($type eq "join") {
3585         return $self->deparse($op->last, 26); # was join($", @ary)
3586     } else {
3587         return $self->deparse($op, 26);
3588     }
3589 }
3590
3591 sub pure_string {
3592     my ($self, $op) = @_;
3593     my $type = $op->name;
3594
3595     if ($type eq 'const') {
3596         return 1;
3597     }
3598     elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
3599         return $self->pure_string($op->first->sibling);
3600     }
3601     elsif ($type eq 'join') {
3602         my $join_op = $op->first->sibling;  # Skip pushmark
3603         return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
3604
3605         my $gvop = $join_op->first;
3606         return 0 unless $gvop->name eq 'gvsv';
3607         return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
3608
3609         return 0 unless ${$join_op->sibling} eq ${$op->last};
3610         return 0 unless $op->last->name =~ /^(rv2|pad)av$/;
3611     }
3612     elsif ($type eq 'concat') {
3613         return $self->pure_string($op->first)
3614             && $self->pure_string($op->last);
3615     }
3616     elsif (is_scalar($op) || $type =~ /^[ah]elem(fast)?$/) {
3617         return 1;
3618     }
3619     else {
3620         return 0;
3621     }
3622
3623     return 1;
3624 }
3625
3626 sub regcomp {
3627     my $self = shift;
3628     my($op, $cx, $extended) = @_;
3629     my $kid = $op->first;
3630     $kid = $kid->first if $kid->name eq "regcmaybe";
3631     $kid = $kid->first if $kid->name eq "regcreset";
3632     return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
3633     return ($self->deparse($kid, $cx), 0);
3634 }
3635
3636 sub pp_regcomp {
3637     my ($self, $op, $cx) = @_;
3638     return (($self->regcomp($op, $cx, 0))[0]);
3639 }
3640
3641 # osmic acid -- see osmium tetroxide
3642
3643 my %matchwords;
3644 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3645     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3646     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3647
3648 sub matchop {
3649     my $self = shift;
3650     my($op, $cx, $name, $delim) = @_;
3651     my $kid = $op->first;
3652     my ($binop, $var, $re) = ("", "", "");
3653     if ($op->flags & OPf_STACKED) {
3654         $binop = 1;
3655         $var = $self->deparse($kid, 20);
3656         $kid = $kid->sibling;
3657     }
3658     my $quote = 1;
3659     my $extended = ($op->pmflags & PMf_EXTENDED);
3660     if (null $kid) {
3661         my $unbacked = re_unback($op->precomp);
3662         if ($extended) {
3663             $re = re_uninterp_extended(escape_extended_re($unbacked));
3664         } else {
3665             $re = re_uninterp(escape_str(re_unback($op->precomp)));
3666         }
3667     } elsif ($kid->name ne 'regcomp') {
3668         Carp::cluck("found ".$kid->name." where regcomp expected");
3669     } else {
3670         ($re, $quote) = $self->regcomp($kid, 1, $extended);
3671     }
3672     my $flags = "";
3673     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3674     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3675     $flags .= "i" if $op->pmflags & PMf_FOLD;
3676     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3677     $flags .= "o" if $op->pmflags & PMf_KEEP;
3678     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3679     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3680     $flags = $matchwords{$flags} if $matchwords{$flags};
3681     if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3682         $re =~ s/\?/\\?/g;
3683         $re = "?$re?";
3684     } elsif ($quote) {
3685         $re = single_delim($name, $delim, $re);
3686     }
3687     $re = $re . $flags if $quote;
3688     if ($binop) {
3689         return $self->maybe_parens("$var =~ $re", $cx, 20);
3690     } else {
3691         return $re;
3692     }
3693 }
3694
3695 sub pp_match { matchop(@_, "m", "/") }
3696 sub pp_pushre { matchop(@_, "m", "/") }
3697 sub pp_qr { matchop(@_, "qr", "") }
3698
3699 sub pp_split {
3700     my $self = shift;
3701     my($op, $cx) = @_;
3702     my($kid, @exprs, $ary, $expr);
3703     $kid = $op->first;
3704     if ($ {$kid->pmreplroot}) {
3705         $ary = $self->stash_variable('@', $self->gv_name($kid->pmreplroot));
3706     }
3707     for (; !null($kid); $kid = $kid->sibling) {
3708         push @exprs, $self->deparse($kid, 6);
3709     }
3710
3711     # handle special case of split(), and split(" ") that compiles to /\s+/
3712     $kid = $op->first;
3713     if ($kid->flags & OPf_SPECIAL
3714         && $exprs[0] eq '/\\s+/'
3715         && $kid->pmflags & PMf_SKIPWHITE ) {
3716             $exprs[0] = '" "';
3717     }
3718
3719     $expr = "split(" . join(", ", @exprs) . ")";
3720     if ($ary) {
3721         return $self->maybe_parens("$ary = $expr", $cx, 7);
3722     } else {
3723         return $expr;
3724     }
3725 }
3726
3727 # oxime -- any of various compounds obtained chiefly by the action of
3728 # hydroxylamine on aldehydes and ketones and characterized by the
3729 # bivalent grouping C=NOH [Webster's Tenth]
3730
3731 my %substwords;
3732 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3733     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3734     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3735     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3736
3737 sub pp_subst {
3738     my $self = shift;
3739     my($op, $cx) = @_;
3740     my $kid = $op->first;
3741     my($binop, $var, $re, $repl) = ("", "", "", "");
3742     if ($op->flags & OPf_STACKED) {
3743         $binop = 1;
3744         $var = $self->deparse($kid, 20);
3745         $kid = $kid->sibling;
3746     }
3747     my $flags = "";
3748     if (null($op->pmreplroot)) {
3749         $repl = $self->dq($kid);
3750         $kid = $kid->sibling;
3751     } else {
3752         $repl = $op->pmreplroot->first; # skip substcont
3753         while ($repl->name eq "entereval") {
3754             $repl = $repl->first;
3755             $flags .= "e";
3756         }
3757         if ($op->pmflags & PMf_EVAL) {
3758             $repl = $self->deparse($repl, 0);
3759         } else {
3760             $repl = $self->dq($repl);
3761         }
3762     }
3763     my $extended = ($op->pmflags & PMf_EXTENDED);
3764     if (null $kid) {
3765         my $unbacked = re_unback($op->precomp);
3766         if ($extended) {
3767             $re = re_uninterp_extended(escape_extended_re($unbacked));
3768         }
3769         else {
3770             $re = re_uninterp(escape_str($unbacked));
3771         }
3772     } else {
3773         ($re) = $self->regcomp($kid, 1, $extended);
3774     }
3775     $flags .= "e" if $op->pmflags & PMf_EVAL;
3776     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3777     $flags .= "i" if $op->pmflags & PMf_FOLD;
3778     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3779     $flags .= "o" if $op->pmflags & PMf_KEEP;
3780     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3781     $flags .= "x" if $extended;
3782     $flags = $substwords{$flags} if $substwords{$flags};
3783     if ($binop) {
3784         return $self->maybe_parens("$var =~ s"
3785                                    . double_delim($re, $repl) . $flags,
3786                                    $cx, 20);
3787     } else {
3788         return "s". double_delim($re, $repl) . $flags;
3789     }
3790 }
3791
3792 1;
3793 __END__
3794
3795 =head1 NAME
3796
3797 B::Deparse - Perl compiler backend to produce perl code
3798
3799 =head1 SYNOPSIS
3800
3801 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3802         [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3803
3804 =head1 DESCRIPTION
3805
3806 B::Deparse is a backend module for the Perl compiler that generates
3807 perl source code, based on the internal compiled structure that perl
3808 itself creates after parsing a program. The output of B::Deparse won't
3809 be exactly the same as the original source, since perl doesn't keep
3810 track of comments or whitespace, and there isn't a one-to-one
3811 correspondence between perl's syntactical constructions and their
3812 compiled form, but it will often be close. When you use the B<-p>
3813 option, the output also includes parentheses even when they are not
3814 required by precedence, which can make it easy to see if perl is
3815 parsing your expressions the way you intended.
3816
3817 Please note that this module is mainly new and untested code and is
3818 still under development, so it may change in the future.
3819
3820 =head1 OPTIONS
3821
3822 As with all compiler backend options, these must follow directly after
3823 the '-MO=Deparse', separated by a comma but not any white space.
3824
3825 =over 4
3826
3827 =item B<-l>
3828
3829 Add '#line' declarations to the output based on the line and file
3830 locations of the original code.
3831
3832 =item B<-p>
3833
3834 Print extra parentheses. Without this option, B::Deparse includes
3835 parentheses in its output only when they are needed, based on the
3836 structure of your program. With B<-p>, it uses parentheses (almost)
3837 whenever they would be legal. This can be useful if you are used to
3838 LISP, or if you want to see how perl parses your input. If you say
3839
3840     if ($var & 0x7f == 65) {print "Gimme an A!"}
3841     print ($which ? $a : $b), "\n";
3842     $name = $ENV{USER} or "Bob";
3843
3844 C<B::Deparse,-p> will print
3845
3846     if (($var & 0)) {
3847         print('Gimme an A!')
3848     };
3849     (print(($which ? $a : $b)), '???');
3850     (($name = $ENV{'USER'}) or '???')
3851
3852 which probably isn't what you intended (the C<'???'> is a sign that
3853 perl optimized away a constant value).
3854
3855 =item B<-q>
3856
3857 Expand double-quoted strings into the corresponding combinations of
3858 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3859 instance, print
3860
3861     print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3862
3863 as
3864
3865     print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3866           . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3867
3868 Note that the expanded form represents the way perl handles such
3869 constructions internally -- this option actually turns off the reverse
3870 translation that B::Deparse usually does. On the other hand, note that
3871 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3872 of $y into a string before doing the assignment.
3873
3874 =item B<-f>I<FILE>
3875
3876 Normally, B::Deparse deparses the main code of a program, and all the subs
3877 defined in the same file. To include subs defined in other files, pass the
3878 B<-f> option with the filename. You can pass the B<-f> option several times, to
3879 include more than one secondary file.  (Most of the time you don't want to
3880 use it at all.)  You can also use this option to include subs which are
3881 defined in the scope of a B<#line> directive with two parameters.
3882
3883 =item B<-s>I<LETTERS>
3884
3885 Tweak the style of B::Deparse's output. The letters should follow
3886 directly after the 's', with no space or punctuation. The following
3887 options are available:
3888
3889 =over 4
3890
3891 =item B<C>
3892
3893 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3894
3895     if (...) {
3896          ...
3897     } else {
3898          ...
3899     }
3900
3901 instead of
3902
3903     if (...) {
3904          ...
3905     }
3906     else {
3907          ...
3908     }
3909
3910 The default is not to cuddle.
3911
3912 =item B<i>I<NUMBER>
3913
3914 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3915
3916 =item B<T>
3917
3918 Use tabs for each 8 columns of indent. The default is to use only spaces.
3919 For instance, if the style options are B<-si4T>, a line that's indented
3920 3 times will be preceded by one tab and four spaces; if the options were
3921 B<-si8T>, the same line would be preceded by three tabs.
3922
3923 =item B<v>I<STRING>B<.>
3924
3925 Print I<STRING> for the value of a constant that can't be determined
3926 because it was optimized away (mnemonic: this happens when a constant
3927 is used in B<v>oid context). The end of the string is marked by a period.
3928 The string should be a valid perl expression, generally a constant.
3929 Note that unless it's a number, it probably needs to be quoted, and on
3930 a command line quotes need to be protected from the shell. Some
3931 conventional values include 0, 1, 42, '', 'foo', and
3932 'Useless use of constant omitted' (which may need to be
3933 B<-sv"'Useless use of constant omitted'.">
3934 or something similar depending on your shell). The default is '???'.
3935 If you're using B::Deparse on a module or other file that's require'd,
3936 you shouldn't use a value that evaluates to false, since the customary
3937 true constant at the end of a module will be in void context when the
3938 file is compiled as a main program.
3939
3940 =back
3941
3942 =item B<-x>I<LEVEL>
3943
3944 Expand conventional syntax constructions into equivalent ones that expose
3945 their internal operation. I<LEVEL> should be a digit, with higher values
3946 meaning more expansion. As with B<-q>, this actually involves turning off
3947 special cases in B::Deparse's normal operations.
3948
3949 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3950 while loops with continue blocks; for instance
3951
3952     for ($i = 0; $i < 10; ++$i) {
3953         print $i;
3954     }
3955
3956 turns into
3957
3958     $i = 0;
3959     while ($i < 10) {
3960         print $i;
3961     } continue {
3962         ++$i
3963     }
3964
3965 Note that in a few cases this translation can't be perfectly carried back
3966 into the source code -- if the loop's initializer declares a my variable,
3967 for instance, it won't have the correct scope outside of the loop.
3968
3969 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3970 expressions using C<&&>, C<?:> and C<do {}>; for instance
3971
3972     print 'hi' if $nice;
3973     if ($nice) {
3974         print 'hi';
3975     }
3976     if ($nice) {
3977         print 'hi';
3978     } else {
3979         print 'bye';
3980     }
3981
3982 turns into
3983
3984     $nice and print 'hi';
3985     $nice and do { print 'hi' };
3986     $nice ? do { print 'hi' } : do { print 'bye' };
3987
3988 Long sequences of elsifs will turn into nested ternary operators, which
3989 B::Deparse doesn't know how to indent nicely.
3990
3991 =back
3992
3993 =head1 USING B::Deparse AS A MODULE
3994
3995 =head2 Synopsis
3996
3997     use B::Deparse;
3998     $deparse = B::Deparse->new("-p", "-sC");
3999     $body = $deparse->coderef2text(\&func);
4000     eval "sub func $body"; # the inverse operation
4001
4002 =head2 Description
4003
4004 B::Deparse can also be used on a sub-by-sub basis from other perl
4005 programs.
4006
4007 =head2 new
4008
4009     $deparse = B::Deparse->new(OPTIONS)
4010
4011 Create an object to store the state of a deparsing operation and any
4012 options. The options are the same as those that can be given on the
4013 command line (see L</OPTIONS>); options that are separated by commas
4014 after B<-MO=Deparse> should be given as separate strings. Some
4015 options, like B<-u>, don't make sense for a single subroutine, so
4016 don't pass them.
4017
4018 =head2 ambient_pragmas
4019
4020     $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
4021
4022 The compilation of a subroutine can be affected by a few compiler
4023 directives, B<pragmas>. These are:
4024
4025 =over 4
4026
4027 =item *
4028
4029 use strict;
4030
4031 =item *
4032
4033 use warnings;
4034
4035 =item *
4036
4037 Assigning to the special variable $[
4038
4039 =item *
4040
4041 use integer;
4042
4043 =item *
4044
4045 use bytes;
4046
4047 =item *
4048
4049 use utf8;
4050
4051 =item *
4052
4053 use re;
4054
4055 =back
4056
4057 Ordinarily, if you use B::Deparse on a subroutine which has
4058 been compiled in the presence of one or more of these pragmas,
4059 the output will include statements to turn on the appropriate
4060 directives. So if you then compile the code returned by coderef2text,
4061 it will behave the same way as the subroutine which you deparsed.
4062
4063 However, you may know that you intend to use the results in a
4064 particular context, where some pragmas are already in scope. In
4065 this case, you use the B<ambient_pragmas> method to describe the
4066 assumptions you wish to make.
4067
4068 Not all of the options currently have any useful effect. See
4069 L</BUGS> for more details.
4070
4071 The parameters it accepts are:
4072
4073 =over 4
4074
4075 =item strict
4076
4077 Takes a string, possibly containing several values separated
4078 by whitespace. The special values "all" and "none" mean what you'd
4079 expect.
4080
4081     $deparse->ambient_pragmas(strict => 'subs refs');
4082
4083 =item $[
4084
4085 Takes a number, the value of the array base $[.
4086
4087 =item bytes
4088
4089 =item utf8
4090
4091 =item integer
4092
4093 If the value is true, then the appropriate pragma is assumed to
4094 be in the ambient scope, otherwise not.
4095
4096 =item re
4097
4098 Takes a string, possibly containing a whitespace-separated list of
4099 values. The values "all" and "none" are special. It's also permissible
4100 to pass an array reference here.
4101
4102     $deparser->ambient_pragmas(re => 'eval');
4103
4104
4105 =item warnings
4106
4107 Takes a string, possibly containing a whitespace-separated list of
4108 values. The values "all" and "none" are special, again. It's also
4109 permissible to pass an array reference here.
4110
4111     $deparser->ambient_pragmas(warnings => [qw[void io]]);
4112
4113 If one of the values is the string "FATAL", then all the warnings
4114 in that list will be considered fatal, just as with the B<warnings>
4115 pragma itself. Should you need to specify that some warnings are
4116 fatal, and others are merely enabled, you can pass the B<warnings>
4117 parameter twice:
4118
4119     $deparser->ambient_pragmas(
4120         warnings => 'all',
4121         warnings => [FATAL => qw/void io/],
4122     );
4123
4124 See L<perllexwarn> for more information about lexical warnings.
4125
4126 =item hint_bits
4127
4128 =item warning_bits
4129
4130 These two parameters are used to specify the ambient pragmas in
4131 the format used by the special variables $^H and ${^WARNING_BITS}.
4132
4133 They exist principally so that you can write code like:
4134
4135     { my ($hint_bits, $warning_bits);
4136     BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
4137     $deparser->ambient_pragmas (
4138         hint_bits    => $hint_bits,
4139         warning_bits => $warning_bits,
4140         '$['         => 0 + $[
4141     ); }
4142
4143 which specifies that the ambient pragmas are exactly those which
4144 are in scope at the point of calling.
4145
4146 =back
4147
4148 =head2 coderef2text
4149
4150     $body = $deparse->coderef2text(\&func)
4151     $body = $deparse->coderef2text(sub ($$) { ... })
4152
4153 Return source code for the body of a subroutine (a block, optionally
4154 preceded by a prototype in parens), given a reference to the
4155 sub. Because a subroutine can have no names, or more than one name,
4156 this method doesn't return a complete subroutine definition -- if you
4157 want to eval the result, you should prepend "sub subname ", or "sub "
4158 for an anonymous function constructor. Unless the sub was defined in
4159 the main:: package, the code will include a package declaration.
4160
4161 =head1 BUGS
4162
4163 =over 4
4164
4165 =item *
4166
4167 The only pragmas to be completely supported are: C<use warnings>,
4168 C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
4169 behaves like a pragma, is also supported.)
4170
4171 Excepting those listed above, we're currently unable to guarantee that
4172 B::Deparse will produce a pragma at the correct point in the program.
4173 Since the effects of pragmas are often lexically scoped, this can mean
4174 that the pragma holds sway over a different portion of the program
4175 than in the input file.
4176
4177 =item *
4178
4179 In fact, the above is a specific instance of a more general problem:
4180 we can't guarantee to produce BEGIN blocks or C<use> declarations in
4181 exactly the right place. So if you use a module which affects compilation
4182 (such as by over-riding keywords, overloading constants or whatever)
4183 then the output code might not work as intended.
4184
4185 This is the most serious outstanding problem, and will be very hard
4186 to fix.
4187
4188 =item *
4189
4190 If a keyword is over-ridden, and your program explicitly calls
4191 the built-in version by using CORE::keyword, the output of B::Deparse
4192 will not reflect this. If you run the resulting code, it will call
4193 the over-ridden version rather than the built-in one. (Maybe there
4194 should be an option to B<always> print keyword calls as C<CORE::name>.)
4195
4196 =item *
4197
4198 C<sort foo (1, 2, 3)> comes out as C<sort (foo 1, 2, 3)>, which
4199 causes perl to issue a warning.
4200
4201 The obvious fix doesn't work, because these are different:
4202
4203     print (FOO 1, 2, 3), 4, 5, 6;
4204     print FOO (1, 2, 3), 4, 5, 6;
4205
4206 =item *
4207
4208 Constants (other than simple strings or numbers) don't work properly.
4209 Pathological examples that fail (and probably always will) include:
4210
4211     use constant E2BIG => ($!=7);
4212     use constant x=>\$x; print x
4213
4214 The following could (and should) be made to work:
4215
4216     use constant regex => qr/blah/;
4217     print regex;
4218
4219 =item *
4220
4221 An input file that uses source filtering probably won't be deparsed into
4222 runnable code, because it will still include the B<use> declaration
4223 for the source filtering module, even though the code that is
4224 produced is already ordinary Perl which shouldn't be filtered again.
4225
4226 =item *
4227
4228 There are probably many more bugs on non-ASCII platforms (EBCDIC).
4229
4230 =back
4231
4232 =head1 AUTHOR
4233
4234 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
4235 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
4236 contributions from Gisle Aas, James Duncan, Albert Dvornik, Robin
4237 Houston, Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons,
4238 and Rafael Garcia-Suarez.
4239
4240 =cut