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