ext/B/B/Deparse.pm

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