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 (is_state $kid->last) { # 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                 if ($self->padname_sv($enter->targ)->IVX ==
2350                     $kid->first->first->sibling->last->cop_seq)
2351                 {
2352                     # If the scope of this variable closes at the last
2353                     # statement of the loop, it must have been
2354                     # declared here.
2355                     $var = "my " . $var;
2356                 }
2357             }
2358         } elsif ($var->name eq "rv2gv") {
2359             $var = $self->pp_rv2sv($var, 1);
2360         } elsif ($var->name eq "gv") {
2361             $var = "\$" . $self->deparse($var, 1);
2362         }
2363         $head = "foreach $var ($ary) ";
2364         $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2365     } elsif ($kid->name eq "null") { # while/until
2366         $kid = $kid->first;
2367         my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2368         $cond = $self->deparse($kid->first, 1);
2369         $head = "$name ($cond) ";
2370         $body = $kid->first->sibling;
2371     } elsif ($kid->name eq "stub") { # bare and empty
2372         return "{;}"; # {} could be a hashref
2373     }
2374     # If there isn't a continue block, then the next pointer for the loop
2375     # will point to the unstack, which is kid's penultimate child, except
2376     # in a bare loop, when it will point to the leaveloop. When neither of
2377     # these conditions hold, then the third-to-last child in the continue
2378     # block (or the last in a bare loop).
2379     my $cont_start = $enter->nextop;
2380     my $cont;
2381     if ($$cont_start != $$op && ${$cont_start->sibling} != ${$body->last}) {
2382         if ($bare) {
2383             $cont = $body->last;
2384         } else {
2385             $cont = $body->first;
2386             while (!null($cont->sibling->sibling->sibling)) {
2387                 $cont = $cont->sibling;
2388             }
2389         }
2390         my $state = $body->first;
2391         my $cuddle = $self->{'cuddle'};
2392         my @states;
2393         for (; $$state != $$cont; $state = $state->sibling) {
2394             push @states, $state;
2395         }
2396         $body = $self->lineseq(undef, @states);
2397         if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2398             $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2399             $cont = "\cK";
2400         } else {
2401             $cont = $cuddle . "continue {\n\t" .
2402               $self->deparse($cont, 0) . "\n\b}\cK";
2403         }
2404     } else {
2405         return "" if !defined $body;
2406         if (length $init) {
2407             $head = "for ($init; $cond;) ";
2408         }
2409         $cont = "\cK";
2410         $body = $self->deparse($body, 0);
2411     }
2412     $body =~ s/;?$/;\n/;
2413
2414     return $head . "{\n\t" . $body . "\b}" . $cont;
2415 }
2416
2417 sub pp_leaveloop { loop_common(@_, "") }
2418
2419 sub for_loop {
2420     my $self = shift;
2421     my($op, $cx) = @_;
2422     my $init = $self->deparse($op, 1);
2423     return $self->loop_common($op->sibling->first->sibling, $cx, $init);
2424 }
2425
2426 sub pp_leavetry {
2427     my $self = shift;
2428     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2429 }
2430
2431 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2432 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2433 BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
2434 BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
2435
2436 sub pp_null {
2437     my $self = shift;
2438     my($op, $cx, $flags) = @_;
2439     if (class($op) eq "OP") {
2440         # old value is lost
2441         return $self->{'ex_const'} if $op->targ == OP_CONST;
2442     } elsif ($op->first->name eq "pushmark") {
2443         return $self->pp_list($op, $cx);
2444     } elsif ($op->first->name eq "enter") {
2445         return $self->pp_leave($op, $cx);
2446     } elsif ($op->targ == OP_STRINGIFY) {
2447         return $self->dquote($op, $cx);
2448     } elsif (!null($op->first->sibling) and
2449              $op->first->sibling->name eq "readline" and
2450              $op->first->sibling->flags & OPf_STACKED) {
2451         return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2452                                    . $self->deparse($op->first->sibling, 7),
2453                                    $cx, 7);
2454     } elsif (!null($op->first->sibling) and
2455              $op->first->sibling->name eq "trans" and
2456              $op->first->sibling->flags & OPf_STACKED) {
2457         return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2458                                    . $self->deparse($op->first->sibling, 20),
2459                                    $cx, 20);
2460     } elsif ($op->flags & OPf_SPECIAL && $cx == 0 && !$op->targ) {
2461         if ($flags) {
2462             return $self->deparse($op->first, $cx);
2463         }
2464         else {
2465             return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
2466         }
2467     } elsif (!null($op->first->sibling) and
2468              $op->first->sibling->name eq "null" and
2469              class($op->first->sibling) eq "UNOP" and
2470              $op->first->sibling->first->flags & OPf_STACKED and
2471              $op->first->sibling->first->name eq "rcatline") {
2472         return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
2473                                    . $self->deparse($op->first->sibling, 18),
2474                                    $cx, 18);
2475     } else {
2476         return $self->deparse($op->first, $cx);
2477     }
2478 }
2479
2480 sub padname {
2481     my $self = shift;
2482     my $targ = shift;
2483     return $self->padname_sv($targ)->PVX;
2484 }
2485
2486 sub padany {
2487     my $self = shift;
2488     my $op = shift;
2489     return substr($self->padname($op->targ), 1); # skip $/@/%
2490 }
2491
2492 sub pp_padsv {
2493     my $self = shift;
2494     my($op, $cx) = @_;
2495     return $self->maybe_my($op, $cx, $self->padname($op->targ));
2496 }
2497
2498 sub pp_padav { pp_padsv(@_) }
2499 sub pp_padhv { pp_padsv(@_) }
2500
2501 my @threadsv_names;
2502
2503 BEGIN {
2504     @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2505                        "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2506                        "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2507                        "!", "@");
2508 }
2509
2510 sub pp_threadsv {
2511     my $self = shift;
2512     my($op, $cx) = @_;
2513     return $self->maybe_local($op, $cx, "\$" .  $threadsv_names[$op->targ]);
2514 }
2515
2516 sub gv_or_padgv {
2517     my $self = shift;
2518     my $op = shift;
2519     if (class($op) eq "PADOP") {
2520         return $self->padval($op->padix);
2521     } else { # class($op) eq "SVOP"
2522         return $op->gv;
2523     }
2524 }
2525
2526 sub pp_gvsv {
2527     my $self = shift;
2528     my($op, $cx) = @_;
2529     my $gv = $self->gv_or_padgv($op);
2530     return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2531                                  $self->gv_name($gv)));
2532 }
2533
2534 sub pp_gv {
2535     my $self = shift;
2536     my($op, $cx) = @_;
2537     my $gv = $self->gv_or_padgv($op);
2538     return $self->gv_name($gv);
2539 }
2540
2541 sub pp_aelemfast {
2542     my $self = shift;
2543     my($op, $cx) = @_;
2544     my $gv = $self->gv_or_padgv($op);
2545     my $name = $self->gv_name($gv);
2546     $name = $self->{'curstash'}."::$name"
2547         if $name !~ /::/ && $self->lex_in_scope('@'.$name);
2548
2549     return "\$" . $name . "[" .
2550                   ($op->private + $self->{'arybase'}) . "]";
2551 }
2552
2553 sub rv2x {
2554     my $self = shift;
2555     my($op, $cx, $type) = @_;
2556
2557     if (class($op) eq 'NULL' || !$op->can("first")) {
2558         carp("Unexpected op in pp_rv2x");
2559         return 'XXX';
2560     }
2561     my $kid = $op->first;
2562     my $str = $self->deparse($kid, 0);
2563     return $self->stash_variable($type, $str) if is_scalar($kid);
2564     return $type ."{$str}";
2565 }
2566
2567 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2568 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2569 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2570
2571 # skip rv2av
2572 sub pp_av2arylen {
2573     my $self = shift;
2574     my($op, $cx) = @_;
2575     if ($op->first->name eq "padav") {
2576         return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2577     } else {
2578         return $self->maybe_local($op, $cx,
2579                                   $self->rv2x($op->first, $cx, '$#'));
2580     }
2581 }
2582
2583 # skip down to the old, ex-rv2cv
2584 sub pp_rv2cv {
2585     my ($self, $op, $cx) = @_;
2586     if (!null($op->first) && $op->first->name eq 'null' &&
2587         $op->first->targ eq OP_LIST)
2588     {
2589         return $self->rv2x($op->first->first->sibling, $cx, "&")
2590     }
2591     else {
2592         return $self->rv2x($op, $cx, "")
2593     }
2594 }
2595
2596 sub pp_rv2av {
2597     my $self = shift;
2598     my($op, $cx) = @_;
2599     my $kid = $op->first;
2600     if ($kid->name eq "const") { # constant list
2601         my $av = $self->const_sv($kid);
2602         return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2603     } else {
2604         return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2605     }
2606  }
2607
2608 sub is_subscriptable {
2609     my $op = shift;
2610     if ($op->name =~ /^[ahg]elem/) {
2611         return 1;
2612     } elsif ($op->name eq "entersub") {
2613         my $kid = $op->first;
2614         return 0 unless null $kid->sibling;
2615         $kid = $kid->first;
2616         $kid = $kid->sibling until null $kid->sibling;
2617         return 0 if is_scope($kid);
2618         $kid = $kid->first;
2619         return 0 if $kid->name eq "gv";
2620         return 0 if is_scalar($kid);
2621         return is_subscriptable($kid);
2622     } else {
2623         return 0;
2624     }
2625 }
2626
2627 sub elem {
2628     my $self = shift;
2629     my ($op, $cx, $left, $right, $padname) = @_;
2630     my($array, $idx) = ($op->first, $op->first->sibling);
2631     unless ($array->name eq $padname) { # Maybe this has been fixed
2632         $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2633     }
2634     if ($array->name eq $padname) {
2635         $array = $self->padany($array);
2636     } elsif (is_scope($array)) { # ${expr}[0]
2637         $array = "{" . $self->deparse($array, 0) . "}";
2638     } elsif ($array->name eq "gv") {
2639         $array = $self->gv_name($self->gv_or_padgv($array));
2640         if ($array !~ /::/) {
2641             my $prefix = ($left eq '[' ? '@' : '%');
2642             $array = $self->{curstash}.'::'.$array
2643                 if $self->lex_in_scope($prefix . $array);
2644         }
2645     } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2646         $array = $self->deparse($array, 24);
2647     } else {
2648         # $x[20][3]{hi} or expr->[20]
2649         my $arrow = is_subscriptable($array) ? "" : "->";
2650         return $self->deparse($array, 24) . $arrow .
2651             $left . $self->deparse($idx, 1) . $right;
2652     }
2653     $idx = $self->deparse($idx, 1);
2654
2655     # Outer parens in an array index will confuse perl
2656     # if we're interpolating in a regular expression, i.e.
2657     # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2658     #
2659     # If $self->{parens}, then an initial '(' will
2660     # definitely be paired with a final ')'. If
2661     # !$self->{parens}, the misleading parens won't
2662     # have been added in the first place.
2663     #
2664     # [You might think that we could get "(...)...(...)"
2665     # where the initial and final parens do not match
2666     # each other. But we can't, because the above would
2667     # only happen if there's an infix binop between the
2668     # two pairs of parens, and *that* means that the whole
2669     # expression would be parenthesized as well.]
2670     #
2671     $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2672
2673     # Hash-element braces will autoquote a bareword inside themselves.
2674     # We need to make sure that C<$hash{warn()}> doesn't come out as
2675     # C<$hash{warn}>, which has a quite different meaning. Currently
2676     # B::Deparse will always quote strings, even if the string was a
2677     # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
2678     # for constant strings.) So we can cheat slightly here - if we see
2679     # a bareword, we know that it is supposed to be a function call.
2680     #
2681     $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
2682
2683     return "\$" . $array . $left . $idx . $right;
2684 }
2685
2686 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2687 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2688
2689 sub pp_gelem {
2690     my $self = shift;
2691     my($op, $cx) = @_;
2692     my($glob, $part) = ($op->first, $op->last);
2693     $glob = $glob->first; # skip rv2gv
2694     $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2695     my $scope = is_scope($glob);
2696     $glob = $self->deparse($glob, 0);
2697     $part = $self->deparse($part, 1);
2698     return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2699 }
2700
2701 sub slice {
2702     my $self = shift;
2703     my ($op, $cx, $left, $right, $regname, $padname) = @_;
2704     my $last;
2705     my(@elems, $kid, $array, $list);
2706     if (class($op) eq "LISTOP") {
2707         $last = $op->last;
2708     } else { # ex-hslice inside delete()
2709         for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2710         $last = $kid;
2711     }
2712     $array = $last;
2713     $array = $array->first
2714         if $array->name eq $regname or $array->name eq "null";
2715     if (is_scope($array)) {
2716         $array = "{" . $self->deparse($array, 0) . "}";
2717     } elsif ($array->name eq $padname) {
2718         $array = $self->padany($array);
2719     } else {
2720         $array = $self->deparse($array, 24);
2721     }
2722     $kid = $op->first->sibling; # skip pushmark
2723     if ($kid->name eq "list") {
2724         $kid = $kid->first->sibling; # skip list, pushmark
2725         for (; !null $kid; $kid = $kid->sibling) {
2726             push @elems, $self->deparse($kid, 6);
2727         }
2728         $list = join(", ", @elems);
2729     } else {
2730         $list = $self->deparse($kid, 1);
2731     }
2732     return "\@" . $array . $left . $list . $right;
2733 }
2734
2735 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2736 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2737
2738 sub pp_lslice {
2739     my $self = shift;
2740     my($op, $cx) = @_;
2741     my $idx = $op->first;
2742     my $list = $op->last;
2743     my(@elems, $kid);
2744     $list = $self->deparse($list, 1);
2745     $idx = $self->deparse($idx, 1);
2746     return "($list)" . "[$idx]";
2747 }
2748
2749 sub want_scalar {
2750     my $op = shift;
2751     return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2752 }
2753
2754 sub want_list {
2755     my $op = shift;
2756     return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2757 }
2758
2759 sub method {
2760     my $self = shift;
2761     my($op, $cx) = @_;
2762     my $kid = $op->first->sibling; # skip pushmark
2763     my($meth, $obj, @exprs);
2764     if ($kid->name eq "list" and want_list $kid) {
2765         # When an indirect object isn't a bareword but the args are in
2766         # parens, the parens aren't part of the method syntax (the LLAFR
2767         # doesn't apply), but they make a list with OPf_PARENS set that
2768         # doesn't get flattened by the append_elem that adds the method,
2769         # making a (object, arg1, arg2, ...) list where the object
2770         # usually is. This can be distinguished from
2771         # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2772         # object) because in the later the list is in scalar context
2773         # as the left side of -> always is, while in the former
2774         # the list is in list context as method arguments always are.
2775         # (Good thing there aren't method prototypes!)
2776         $meth = $kid->sibling;
2777         $kid = $kid->first->sibling; # skip pushmark
2778         $obj = $kid;
2779         $kid = $kid->sibling;
2780         for (; not null $kid; $kid = $kid->sibling) {
2781             push @exprs, $self->deparse($kid, 6);
2782         }
2783     } else {
2784         $obj = $kid;
2785         $kid = $kid->sibling;
2786         for (; !null ($kid->sibling) && $kid->name ne "method_named";
2787               $kid = $kid->sibling) {
2788             push @exprs, $self->deparse($kid, 6);
2789         }
2790         $meth = $kid;
2791     }
2792     $obj = $self->deparse($obj, 24);
2793     if ($meth->name eq "method_named") {
2794         $meth = $self->const_sv($meth)->PV;
2795     } else {
2796         $meth = $meth->first;
2797         if ($meth->name eq "const") {
2798             # As of 5.005_58, this case is probably obsoleted by the
2799             # method_named case above
2800             $meth = $self->const_sv($meth)->PV; # needs to be bare
2801         } else {
2802             $meth = $self->deparse($meth, 1);
2803         }
2804     }
2805     my $args = join(", ", @exprs);
2806     $kid = $obj . "->" . $meth;
2807     if (length $args) {
2808         return $kid . "(" . $args . ")"; # parens mandatory
2809     } else {
2810         return $kid;
2811     }
2812 }
2813
2814 # returns "&" if the prototype doesn't match the args,
2815 # or ("", $args_after_prototype_demunging) if it does.
2816 sub check_proto {
2817     my $self = shift;
2818     return "&" if $self->{'noproto'};
2819     my($proto, @args) = @_;
2820     my($arg, $real);
2821     my $doneok = 0;
2822     my @reals;
2823     # An unbackslashed @ or % gobbles up the rest of the args
2824     1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
2825     while ($proto) {
2826         $proto =~ s/^(\\?[\$\@&%*]|\\\[[\$\@&%*]+\]|;)//;
2827         my $chr = $1;
2828         if ($chr eq "") {
2829             return "&" if @args;
2830         } elsif ($chr eq ";") {
2831             $doneok = 1;
2832         } elsif ($chr eq "@" or $chr eq "%") {
2833             push @reals, map($self->deparse($_, 6), @args);
2834             @args = ();
2835         } else {
2836             $arg = shift @args;
2837             last unless $arg;
2838             if ($chr eq "\$") {
2839                 if (want_scalar $arg) {
2840                     push @reals, $self->deparse($arg, 6);
2841                 } else {
2842                     return "&";
2843                 }
2844             } elsif ($chr eq "&") {
2845                 if ($arg->name =~ /^(s?refgen|undef)$/) {
2846                     push @reals, $self->deparse($arg, 6);
2847                 } else {
2848                     return "&";
2849                 }
2850             } elsif ($chr eq "*") {
2851                 if ($arg->name =~ /^s?refgen$/
2852                     and $arg->first->first->name eq "rv2gv")
2853                   {
2854                       $real = $arg->first->first; # skip refgen, null
2855                       if ($real->first->name eq "gv") {
2856                           push @reals, $self->deparse($real, 6);
2857                       } else {
2858                           push @reals, $self->deparse($real->first, 6);
2859                       }
2860                   } else {
2861                       return "&";
2862                   }
2863             } elsif (substr($chr, 0, 1) eq "\\") {
2864                 $chr =~ tr/\\[]//d;
2865                 if ($arg->name =~ /^s?refgen$/ and
2866                     !null($real = $arg->first) and
2867                     ($chr =~ /\$/ && is_scalar($real->first)
2868                      or ($chr =~ /@/
2869                          && class($real->first->sibling) ne 'NULL'
2870                          && $real->first->sibling->name
2871                          =~ /^(rv2|pad)av$/)
2872                      or ($chr =~ /%/
2873                          && class($real->first->sibling) ne 'NULL'
2874                          && $real->first->sibling->name
2875                          =~ /^(rv2|pad)hv$/)
2876                      #or ($chr =~ /&/ # This doesn't work
2877                      #   && $real->first->name eq "rv2cv")
2878                      or ($chr =~ /\*/
2879                          && $real->first->name eq "rv2gv")))
2880                   {
2881                       push @reals, $self->deparse($real, 6);
2882                   } else {
2883                       return "&";
2884                   }
2885             }
2886        }
2887     }
2888     return "&" if $proto and !$doneok; # too few args and no `;'
2889     return "&" if @args;               # too many args
2890     return ("", join ", ", @reals);
2891 }
2892
2893 sub pp_entersub {
2894     my $self = shift;
2895     my($op, $cx) = @_;
2896     return $self->method($op, $cx) unless null $op->first->sibling;
2897     my $prefix = "";
2898     my $amper = "";
2899     my($kid, @exprs);
2900     if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
2901         $prefix = "do ";
2902     } elsif ($op->private & OPpENTERSUB_AMPER) {
2903         $amper = "&";
2904     }
2905     $kid = $op->first;
2906     $kid = $kid->first->sibling; # skip ex-list, pushmark
2907     for (; not null $kid->sibling; $kid = $kid->sibling) {
2908         push @exprs, $kid;
2909     }
2910     my $simple = 0;
2911     my $proto = undef;
2912     if (is_scope($kid)) {
2913         $amper = "&";
2914         $kid = "{" . $self->deparse($kid, 0) . "}";
2915     } elsif ($kid->first->name eq "gv") {
2916         my $gv = $self->gv_or_padgv($kid->first);
2917         if (class($gv->CV) ne "SPECIAL") {
2918             $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2919         }
2920         $simple = 1; # only calls of named functions can be prototyped
2921         $kid = $self->deparse($kid, 24);
2922     } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
2923         $amper = "&";
2924         $kid = $self->deparse($kid, 24);
2925     } else {
2926         $prefix = "";
2927         my $arrow = is_subscriptable($kid->first) ? "" : "->";
2928         $kid = $self->deparse($kid, 24) . $arrow;
2929     }
2930
2931     # Doesn't matter how many prototypes there are, if
2932     # they haven't happened yet!
2933     my $declared;
2934     {
2935         no strict 'refs';
2936         no warnings 'uninitialized';
2937         $declared = exists $self->{'subs_declared'}{$kid}
2938             || (
2939                  defined &{ %{$self->{'curstash'}."::"}->{$kid} }
2940                  && !exists
2941                      $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
2942                  && defined prototype $self->{'curstash'}."::".$kid
2943                );
2944         if (!$declared && defined($proto)) {
2945             # Avoid "too early to check prototype" warning
2946             ($amper, $proto) = ('&');
2947         }
2948     }
2949
2950     my $args;
2951     if ($declared and defined $proto and not $amper) {
2952         ($amper, $args) = $self->check_proto($proto, @exprs);
2953         if ($amper eq "&") {
2954             $args = join(", ", map($self->deparse($_, 6), @exprs));
2955         }
2956     } else {
2957         $args = join(", ", map($self->deparse($_, 6), @exprs));
2958     }
2959     if ($prefix or $amper) {
2960         if ($op->flags & OPf_STACKED) {
2961             return $prefix . $amper . $kid . "(" . $args . ")";
2962         } else {
2963             return $prefix . $amper. $kid;
2964         }
2965     } else {
2966         # glob() invocations can be translated into calls of
2967         # CORE::GLOBAL::glob with a second parameter, a number.
2968         # Reverse this.
2969         if ($kid eq "CORE::GLOBAL::glob") {
2970             $kid = "glob";
2971             $args =~ s/\s*,[^,]+$//;
2972         }
2973
2974         # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
2975         # so it must have been translated from a keyword call. Translate
2976         # it back.
2977         $kid =~ s/^CORE::GLOBAL:://;
2978
2979         if (!$declared) {
2980             return "$kid(" . $args . ")";
2981         } elsif (defined $proto and $proto eq "") {
2982             return $kid;
2983         } elsif (defined $proto and $proto eq "\$" and is_scalar($exprs[0])) {
2984             return $self->maybe_parens_func($kid, $args, $cx, 16);
2985         } elsif (defined($proto) && $proto or $simple) {
2986             return $self->maybe_parens_func($kid, $args, $cx, 5);
2987         } else {
2988             return "$kid(" . $args . ")";
2989         }
2990     }
2991 }
2992
2993 sub pp_enterwrite { unop(@_, "write") }
2994
2995 # escape things that cause interpolation in double quotes,
2996 # but not character escapes
2997 sub uninterp {
2998     my($str) = @_;
2999     $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
3000     return $str;
3001 }
3002
3003 {
3004 my $bal;
3005 BEGIN {
3006     use re "eval";
3007     # Matches any string which is balanced with respect to {braces}
3008     $bal = qr(
3009       (?:
3010         [^\\{}]
3011       | \\\\
3012       | \\[{}]
3013       | \{(??{$bal})\}
3014       )*
3015     )x;
3016 }
3017
3018 # the same, but treat $|, $), $( and $ at the end of the string differently
3019 sub re_uninterp {
3020     my($str) = @_;
3021
3022     $str =~ s/
3023           ( ^|\G                  # $1
3024           | [^\\]
3025           )
3026
3027           (                       # $2
3028             (?:\\\\)*
3029           )
3030
3031           (                       # $3
3032             (\(\?\??\{$bal\}\))   # $4
3033           | [\$\@]
3034             (?!\||\)|\(|$)
3035           | \\[uUlLQE]
3036           )
3037
3038         /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3039
3040     return $str;
3041 }
3042
3043 # This is for regular expressions with the /x modifier
3044 # We have to leave comments unmangled.
3045 sub re_uninterp_extended {
3046     my($str) = @_;
3047
3048     $str =~ s/
3049           ( ^|\G                  # $1
3050           | [^\\]
3051           )
3052
3053           (                       # $2
3054             (?:\\\\)*
3055           )
3056
3057           (                       # $3
3058             ( \(\?\??\{$bal\}\)   # $4  (skip over (?{}) and (??{}) blocks)
3059             | \#[^\n]*            #     (skip over comments)
3060             )
3061           | [\$\@]
3062             (?!\||\)|\(|$|\s)
3063           | \\[uUlLQE]
3064           )
3065
3066         /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3067
3068     return $str;
3069 }
3070 }
3071
3072 my %unctrl = # portable to to EBCDIC
3073     (
3074      "\c@" => '\c@',    # unused
3075      "\cA" => '\cA',
3076      "\cB" => '\cB',
3077      "\cC" => '\cC',
3078      "\cD" => '\cD',
3079      "\cE" => '\cE',
3080      "\cF" => '\cF',
3081      "\cG" => '\cG',
3082      "\cH" => '\cH',
3083      "\cI" => '\cI',
3084      "\cJ" => '\cJ',
3085      "\cK" => '\cK',
3086      "\cL" => '\cL',
3087      "\cM" => '\cM',
3088      "\cN" => '\cN',
3089      "\cO" => '\cO',
3090      "\cP" => '\cP',
3091      "\cQ" => '\cQ',
3092      "\cR" => '\cR',
3093      "\cS" => '\cS',
3094      "\cT" => '\cT',
3095      "\cU" => '\cU',
3096      "\cV" => '\cV',
3097      "\cW" => '\cW',
3098      "\cX" => '\cX',
3099      "\cY" => '\cY',
3100      "\cZ" => '\cZ',
3101      "\c[" => '\c[',    # unused
3102      "\c\\" => '\c\\',  # unused
3103      "\c]" => '\c]',    # unused
3104      "\c_" => '\c_',    # unused
3105     );
3106
3107 # character escapes, but not delimiters that might need to be escaped
3108 sub escape_str { # ASCII, UTF8
3109     my($str) = @_;
3110     $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3111     $str =~ s/\a/\\a/g;
3112 #    $str =~ s/\cH/\\b/g; # \b means something different in a regex
3113     $str =~ s/\t/\\t/g;
3114     $str =~ s/\n/\\n/g;
3115     $str =~ s/\e/\\e/g;
3116     $str =~ s/\f/\\f/g;
3117     $str =~ s/\r/\\r/g;
3118     $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
3119     $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
3120     return $str;
3121 }
3122
3123 # For regexes with the /x modifier.
3124 # Leave whitespace unmangled.
3125 sub escape_extended_re {
3126     my($str) = @_;
3127     $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3128     $str =~ s/([[:^print:]])/
3129         ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
3130     $str =~ s/\n/\n\f/g;
3131     return $str;
3132 }
3133
3134 # Don't do this for regexen
3135 sub unback {
3136     my($str) = @_;
3137     $str =~ s/\\/\\\\/g;
3138     return $str;
3139 }
3140
3141 # Remove backslashes which precede literal control characters,
3142 # to avoid creating ambiguity when we escape the latter.
3143 sub re_unback {
3144     my($str) = @_;
3145
3146     # the insane complexity here is due to the behaviour of "\c\"
3147     $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
3148     return $str;
3149 }
3150
3151 sub balanced_delim {
3152     my($str) = @_;
3153     my @str = split //, $str;
3154     my($ar, $open, $close, $fail, $c, $cnt);
3155     for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
3156         ($open, $close) = @$ar;
3157         $fail = 0; $cnt = 0;
3158         for $c (@str) {
3159             if ($c eq $open) {
3160                 $cnt++;
3161             } elsif ($c eq $close) {
3162                 $cnt--;
3163                 if ($cnt < 0) {
3164                     # qq()() isn't ")("
3165                     $fail = 1;
3166                     last;
3167                 }
3168             }
3169         }
3170         $fail = 1 if $cnt != 0;
3171         return ($open, "$open$str$close") if not $fail;
3172     }
3173     return ("", $str);
3174 }
3175
3176 sub single_delim {
3177     my($q, $default, $str) = @_;
3178     return "$default$str$default" if $default and index($str, $default) == -1;
3179     if ($q ne 'qr') {
3180         (my $succeed, $str) = balanced_delim($str);
3181         return "$q$str" if $succeed;
3182     }
3183     for my $delim ('/', '"', '#') {
3184         return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3185     }
3186     if ($default) {
3187         $str =~ s/$default/\\$default/g;
3188         return "$default$str$default";
3189     } else {
3190         $str =~ s[/][\\/]g;
3191         return "$q/$str/";
3192     }
3193 }
3194
3195 sub const {
3196     my $sv = shift;
3197     if (class($sv) eq "SPECIAL") {
3198         return ('undef', '1', '(!1)')[$$sv-1]; # sv_undef, sv_yes, sv_no
3199     } elsif (class($sv) eq "NULL") {
3200        return 'undef';
3201     } elsif ($sv->FLAGS & SVf_IOK) {
3202         return $sv->int_value;
3203     } elsif ($sv->FLAGS & SVf_NOK) {
3204         # try the default stringification
3205         my $r = "".$sv->NV;
3206         if ($r =~ /e/) {
3207             # If it's in scientific notation, we might have lost information
3208             return sprintf("%.20e", $sv->NV);
3209         }
3210         return $r;
3211     } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3212         return "\\(" . const($sv->RV) . ")"; # constant folded
3213     } elsif ($sv->FLAGS & SVf_POK) {
3214         my $str = $sv->PV;
3215         if ($str =~ /[^ -~]/) { # ASCII for non-printing
3216             return single_delim("qq", '"', uninterp escape_str unback $str);
3217         } else {
3218             return single_delim("q", "'", unback $str);
3219         }
3220     } else {
3221         return "undef";
3222     }
3223 }
3224
3225 sub const_sv {
3226     my $self = shift;
3227     my $op = shift;
3228     my $sv = $op->sv;
3229     # the constant could be in the pad (under useithreads)
3230     $sv = $self->padval($op->targ) unless $$sv;
3231     return $sv;
3232 }
3233
3234 sub pp_const {
3235     my $self = shift;
3236     my($op, $cx) = @_;
3237     if ($op->private & OPpCONST_ARYBASE) {
3238         return '$[';
3239     }
3240 #    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3241 #       return $self->const_sv($op)->PV;
3242 #    }
3243     my $sv = $self->const_sv($op);
3244 #    return const($sv);
3245     my $c = const $sv;
3246     return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
3247 }
3248
3249 sub dq {
3250     my $self = shift;
3251     my $op = shift;
3252     my $type = $op->name;
3253     if ($type eq "const") {
3254         return '$[' if $op->private & OPpCONST_ARYBASE;
3255         return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3256     } elsif ($type eq "concat") {
3257         my $first = $self->dq($op->first);
3258         my $last  = $self->dq($op->last);
3259
3260         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
3261         ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3262             $first =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
3263             || ($last =~ /^[:'{\[\w_]/ &&
3264                 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3265
3266         return $first . $last;
3267     } elsif ($type eq "uc") {
3268         return '\U' . $self->dq($op->first->sibling) . '\E';
3269     } elsif ($type eq "lc") {
3270         return '\L' . $self->dq($op->first->sibling) . '\E';
3271     } elsif ($type eq "ucfirst") {
3272         return '\u' . $self->dq($op->first->sibling);
3273     } elsif ($type eq "lcfirst") {
3274         return '\l' . $self->dq($op->first->sibling);
3275     } elsif ($type eq "quotemeta") {
3276         return '\Q' . $self->dq($op->first->sibling) . '\E';
3277     } elsif ($type eq "join") {
3278         return $self->deparse($op->last, 26); # was join($", @ary)
3279     } else {
3280         return $self->deparse($op, 26);
3281     }
3282 }
3283
3284 sub pp_backtick {
3285     my $self = shift;
3286     my($op, $cx) = @_;
3287     # skip pushmark
3288     return single_delim("qx", '`', $self->dq($op->first->sibling));
3289 }
3290
3291 sub dquote {
3292     my $self = shift;
3293     my($op, $cx) = @_;
3294     my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3295     return $self->deparse($kid, $cx) if $self->{'unquote'};
3296     $self->maybe_targmy($kid, $cx,
3297                         sub {single_delim("qq", '"', $self->dq($_[1]))});
3298 }
3299
3300 # OP_STRINGIFY is a listop, but it only ever has one arg
3301 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3302
3303 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3304 # note that tr(from)/to/ is OK, but not tr/from/(to)
3305 sub double_delim {
3306     my($from, $to) = @_;
3307     my($succeed, $delim);
3308     if ($from !~ m[/] and $to !~ m[/]) {
3309         return "/$from/$to/";
3310     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3311         if (($succeed, $to) = balanced_delim($to) and $succeed) {
3312             return "$from$to";
3313         } else {
3314             for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3315                 return "$from$delim$to$delim" if index($to, $delim) == -1;
3316             }
3317             $to =~ s[/][\\/]g;
3318             return "$from/$to/";
3319         }
3320     } else {
3321         for $delim ('/', '"', '#') { # note no '
3322             return "$delim$from$delim$to$delim"
3323                 if index($to . $from, $delim) == -1;
3324         }
3325         $from =~ s[/][\\/]g;
3326         $to =~ s[/][\\/]g;
3327         return "/$from/$to/";
3328     }
3329 }
3330
3331 # Only used by tr///, so backslashes hyphens
3332 sub pchr { # ASCII
3333     my($n) = @_;
3334     if ($n == ord '\\') {
3335         return '\\\\';
3336     } elsif ($n == ord "-") {
3337         return "\\-";
3338     } elsif ($n >= ord(' ') and $n <= ord('~')) {
3339         return chr($n);
3340     } elsif ($n == ord "\a") {
3341         return '\\a';
3342     } elsif ($n == ord "\b") {
3343         return '\\b';
3344     } elsif ($n == ord "\t") {
3345         return '\\t';
3346     } elsif ($n == ord "\n") {
3347         return '\\n';
3348     } elsif ($n == ord "\e") {
3349         return '\\e';
3350     } elsif ($n == ord "\f") {
3351         return '\\f';
3352     } elsif ($n == ord "\r") {
3353         return '\\r';
3354     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3355         return '\\c' . chr(ord("@") + $n);
3356     } else {
3357 #       return '\x' . sprintf("%02x", $n);
3358         return '\\' . sprintf("%03o", $n);
3359     }
3360 }
3361
3362 sub collapse {
3363     my(@chars) = @_;
3364     my($str, $c, $tr) = ("");
3365     for ($c = 0; $c < @chars; $c++) {
3366         $tr = $chars[$c];
3367         $str .= pchr($tr);
3368         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3369             $chars[$c + 2] == $tr + 2)
3370         {
3371             for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3372               {}
3373             $str .= "-";
3374             $str .= pchr($chars[$c]);
3375         }
3376     }
3377     return $str;
3378 }
3379
3380 sub tr_decode_byte {
3381     my($table, $flags) = @_;
3382     my(@table) = unpack("s*", $table);
3383     splice @table, 0x100, 1;   # Number of subsequent elements
3384     my($c, $tr, @from, @to, @delfrom, $delhyphen);
3385     if ($table[ord "-"] != -1 and
3386         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3387     {
3388         $tr = $table[ord "-"];
3389         $table[ord "-"] = -1;
3390         if ($tr >= 0) {
3391             @from = ord("-");
3392             @to = $tr;
3393         } else { # -2 ==> delete
3394             $delhyphen = 1;
3395         }
3396     }
3397     for ($c = 0; $c < @table; $c++) {
3398         $tr = $table[$c];
3399         if ($tr >= 0) {
3400             push @from, $c; push @to, $tr;
3401         } elsif ($tr == -2) {
3402             push @delfrom, $c;
3403         }
3404     }
3405     @from = (@from, @delfrom);
3406     if ($flags & OPpTRANS_COMPLEMENT) {
3407         my @newfrom = ();
3408         my %from;
3409         @from{@from} = (1) x @from;
3410         for ($c = 0; $c < 256; $c++) {
3411             push @newfrom, $c unless $from{$c};
3412         }
3413         @from = @newfrom;
3414     }
3415     unless ($flags & OPpTRANS_DELETE || !@to) {
3416         pop @to while $#to and $to[$#to] == $to[$#to -1];
3417     }
3418     my($from, $to);
3419     $from = collapse(@from);
3420     $to = collapse(@to);
3421     $from .= "-" if $delhyphen;
3422     return ($from, $to);
3423 }
3424
3425 sub tr_chr {
3426     my $x = shift;
3427     if ($x == ord "-") {
3428         return "\\-";
3429     } elsif ($x == ord "\\") {
3430         return "\\\\";
3431     } else {
3432         return chr $x;
3433     }
3434 }
3435
3436 # XXX This doesn't yet handle all cases correctly either
3437
3438 sub tr_decode_utf8 {
3439     my($swash_hv, $flags) = @_;
3440     my %swash = $swash_hv->ARRAY;
3441     my $final = undef;
3442     $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3443     my $none = $swash{"NONE"}->IV;
3444     my $extra = $none + 1;
3445     my(@from, @delfrom, @to);
3446     my $line;
3447     foreach $line (split /\n/, $swash{'LIST'}->PV) {
3448         my($min, $max, $result) = split(/\t/, $line);
3449         $min = hex $min;
3450         if (length $max) {
3451             $max = hex $max;
3452         } else {
3453             $max = $min;
3454         }
3455         $result = hex $result;
3456         if ($result == $extra) {
3457             push @delfrom, [$min, $max];
3458         } else {
3459             push @from, [$min, $max];
3460             push @to, [$result, $result + $max - $min];
3461         }
3462     }
3463     for my $i (0 .. $#from) {
3464         if ($from[$i][0] == ord '-') {
3465             unshift @from, splice(@from, $i, 1);
3466             unshift @to, splice(@to, $i, 1);
3467             last;
3468         } elsif ($from[$i][1] == ord '-') {
3469             $from[$i][1]--;
3470             $to[$i][1]--;
3471             unshift @from, ord '-';
3472             unshift @to, ord '-';
3473             last;
3474         }
3475     }
3476     for my $i (0 .. $#delfrom) {
3477         if ($delfrom[$i][0] == ord '-') {
3478             push @delfrom, splice(@delfrom, $i, 1);
3479             last;
3480         } elsif ($delfrom[$i][1] == ord '-') {
3481             $delfrom[$i][1]--;
3482             push @delfrom, ord '-';
3483             last;
3484         }
3485     }
3486     if (defined $final and $to[$#to][1] != $final) {
3487         push @to, [$final, $final];
3488     }
3489     push @from, @delfrom;
3490     if ($flags & OPpTRANS_COMPLEMENT) {
3491         my @newfrom;
3492         my $next = 0;
3493         for my $i (0 .. $#from) {
3494             push @newfrom, [$next, $from[$i][0] - 1];
3495             $next = $from[$i][1] + 1;
3496         }
3497         @from = ();
3498         for my $range (@newfrom) {
3499             if ($range->[0] <= $range->[1]) {
3500                 push @from, $range;
3501             }
3502         }
3503     }
3504     my($from, $to, $diff);
3505     for my $chunk (@from) {
3506         $diff = $chunk->[1] - $chunk->[0];
3507         if ($diff > 1) {
3508             $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3509         } elsif ($diff == 1) {
3510             $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3511         } else {
3512             $from .= tr_chr($chunk->[0]);
3513         }
3514     }
3515     for my $chunk (@to) {
3516         $diff = $chunk->[1] - $chunk->[0];
3517         if ($diff > 1) {
3518             $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3519         } elsif ($diff == 1) {
3520             $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3521         } else {
3522             $to .= tr_chr($chunk->[0]);
3523         }
3524     }
3525     #$final = sprintf("%04x", $final) if defined $final;
3526     #$none = sprintf("%04x", $none) if defined $none;
3527     #$extra = sprintf("%04x", $extra) if defined $extra;
3528     #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3529     #print STDERR $swash{'LIST'}->PV;
3530     return (escape_str($from), escape_str($to));
3531 }
3532
3533 sub pp_trans {
3534     my $self = shift;
3535     my($op, $cx) = @_;
3536     my($from, $to);
3537     if (class($op) eq "PVOP") {
3538         ($from, $to) = tr_decode_byte($op->pv, $op->private);
3539     } else { # class($op) eq "SVOP"
3540         ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3541     }
3542     my $flags = "";
3543     $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3544     $flags .= "d" if $op->private & OPpTRANS_DELETE;
3545     $to = "" if $from eq $to and $flags eq "";
3546     $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3547     return "tr" . double_delim($from, $to) . $flags;
3548 }
3549
3550 # Like dq(), but different
3551 sub re_dq {
3552     my $self = shift;
3553     my ($op, $extended) = @_;
3554
3555     my $type = $op->name;
3556     if ($type eq "const") {
3557         return '$[' if $op->private & OPpCONST_ARYBASE;
3558         my $unbacked = re_unback($self->const_sv($op)->as_string);
3559         return re_uninterp_extended(escape_extended_re($unbacked))
3560             if $extended;
3561         return re_uninterp(escape_str($unbacked));
3562     } elsif ($type eq "concat") {
3563         my $first = $self->re_dq($op->first, $extended);
3564         my $last  = $self->re_dq($op->last,  $extended);
3565
3566         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3567         ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3568             $first =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
3569             || ($last =~ /^[{\[\w_]/ &&
3570                 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3571
3572         return $first . $last;
3573     } elsif ($type eq "uc") {
3574         return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
3575     } elsif ($type eq "lc") {
3576         return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
3577     } elsif ($type eq "ucfirst") {
3578         return '\u' . $self->re_dq($op->first->sibling, $extended);
3579     } elsif ($type eq "lcfirst") {
3580         return '\l' . $self->re_dq($op->first->sibling, $extended);
3581     } elsif ($type eq "quotemeta") {
3582         return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
3583     } elsif ($type eq "join") {
3584         return $self->deparse($op->last, 26); # was join($", @ary)
3585     } else {
3586         return $self->deparse($op, 26);
3587     }
3588 }
3589
3590 sub pure_string {
3591     my ($self, $op) = @_;
3592     my $type = $op->name;
3593
3594     if ($type eq 'const') {
3595         return 1;
3596     }
3597     elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
3598         return $self->pure_string($op->first->sibling);
3599     }
3600     elsif ($type eq 'join') {
3601         my $join_op = $op->first->sibling;  # Skip pushmark
3602         return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
3603
3604         my $gvop = $join_op->first;
3605         return 0 unless $gvop->name eq 'gvsv';
3606         return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
3607
3608         return 0 unless ${$join_op->sibling} eq ${$op->last};
3609         return 0 unless $op->last->name =~ /^(rv2|pad)av$/;
3610     }
3611     elsif ($type eq 'concat') {
3612         return $self->pure_string($op->first)
3613             && $self->pure_string($op->last);
3614     }
3615     elsif (is_scalar($op) || $type =~ /^[ah]elem(fast)?$/) {
3616         return 1;
3617     }
3618     else {
3619         return 0;
3620     }
3621
3622     return 1;
3623 }
3624
3625 sub regcomp {
3626     my $self = shift;
3627     my($op, $cx, $extended) = @_;
3628     my $kid = $op->first;
3629     $kid = $kid->first if $kid->name eq "regcmaybe";
3630     $kid = $kid->first if $kid->name eq "regcreset";
3631     return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
3632     return ($self->deparse($kid, $cx), 0);
3633 }
3634
3635 sub pp_regcomp {
3636     my ($self, $op, $cx) = @_;
3637     return (($self->regcomp($op, $cx, 0))[0]);
3638 }
3639
3640 # osmic acid -- see osmium tetroxide
3641
3642 my %matchwords;
3643 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3644     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3645     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3646
3647 sub matchop {
3648     my $self = shift;
3649     my($op, $cx, $name, $delim) = @_;
3650     my $kid = $op->first;
3651     my ($binop, $var, $re) = ("", "", "");
3652     if ($op->flags & OPf_STACKED) {
3653         $binop = 1;
3654         $var = $self->deparse($kid, 20);
3655         $kid = $kid->sibling;
3656     }
3657     my $quote = 1;
3658     my $extended = ($op->pmflags & PMf_EXTENDED);
3659     if (null $kid) {
3660         my $unbacked = re_unback($op->precomp);
3661         if ($extended) {
3662             $re = re_uninterp_extended(escape_extended_re($unbacked));
3663         } else {
3664             $re = re_uninterp(escape_str(re_unback($op->precomp)));
3665         }
3666     } elsif ($kid->name ne 'regcomp') {
3667         carp("found ".$kid->name." where regcomp expected");
3668     } else {
3669         ($re, $quote) = $self->regcomp($kid, 1, $extended);
3670     }
3671     my $flags = "";
3672     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3673     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3674     $flags .= "i" if $op->pmflags & PMf_FOLD;
3675     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3676     $flags .= "o" if $op->pmflags & PMf_KEEP;
3677     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3678     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3679     $flags = $matchwords{$flags} if $matchwords{$flags};
3680     if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3681         $re =~ s/\?/\\?/g;
3682         $re = "?$re?";
3683     } elsif ($quote) {
3684         $re = single_delim($name, $delim, $re);
3685     }
3686     $re = $re . $flags if $quote;
3687     if ($binop) {
3688         return $self->maybe_parens("$var =~ $re", $cx, 20);
3689     } else {
3690         return $re;
3691     }
3692 }
3693
3694 sub pp_match { matchop(@_, "m", "/") }
3695 sub pp_pushre { matchop(@_, "m", "/") }
3696 sub pp_qr { matchop(@_, "qr", "") }
3697
3698 sub pp_split {
3699     my $self = shift;
3700     my($op, $cx) = @_;
3701     my($kid, @exprs, $ary, $expr);
3702     $kid = $op->first;
3703     # under ithreads pmreplroot is an integer, not an SV
3704     my $replroot = $kid->pmreplroot;
3705     if ( ( ref($replroot) && $$replroot ) ||
3706          ( !ref($replroot) && $replroot ) ) {
3707         $ary = $self->stash_variable('@', $self->gv_name($kid->pmreplroot));
3708     }
3709     for (; !null($kid); $kid = $kid->sibling) {
3710         push @exprs, $self->deparse($kid, 6);
3711     }
3712
3713     # handle special case of split(), and split(" ") that compiles to /\s+/
3714     $kid = $op->first;
3715     if ($kid->flags & OPf_SPECIAL
3716         && $exprs[0] eq '/\\s+/'
3717         && $kid->pmflags & PMf_SKIPWHITE ) {
3718             $exprs[0] = '" "';
3719     }
3720
3721     $expr = "split(" . join(", ", @exprs) . ")";
3722     if ($ary) {
3723         return $self->maybe_parens("$ary = $expr", $cx, 7);
3724     } else {
3725         return $expr;
3726     }
3727 }
3728
3729 # oxime -- any of various compounds obtained chiefly by the action of
3730 # hydroxylamine on aldehydes and ketones and characterized by the
3731 # bivalent grouping C=NOH [Webster's Tenth]
3732
3733 my %substwords;
3734 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3735     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3736     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3737     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3738
3739 sub pp_subst {
3740     my $self = shift;
3741     my($op, $cx) = @_;
3742     my $kid = $op->first;
3743     my($binop, $var, $re, $repl) = ("", "", "", "");
3744     if ($op->flags & OPf_STACKED) {
3745         $binop = 1;
3746         $var = $self->deparse($kid, 20);
3747         $kid = $kid->sibling;
3748     }
3749     my $flags = "";
3750     if (null($op->pmreplroot)) {
3751         $repl = $self->dq($kid);
3752         $kid = $kid->sibling;
3753     } else {
3754         $repl = $op->pmreplroot->first; # skip substcont
3755         while ($repl->name eq "entereval") {
3756             $repl = $repl->first;
3757             $flags .= "e";
3758         }
3759         if ($op->pmflags & PMf_EVAL) {
3760             $repl = $self->deparse($repl, 0, 1);
3761         } else {
3762             $repl = $self->dq($repl);
3763         }
3764     }
3765     my $extended = ($op->pmflags & PMf_EXTENDED);
3766     if (null $kid) {
3767         my $unbacked = re_unback($op->precomp);
3768         if ($extended) {
3769             $re = re_uninterp_extended(escape_extended_re($unbacked));
3770         }
3771         else {
3772             $re = re_uninterp(escape_str($unbacked));
3773         }
3774     } else {
3775         ($re) = $self->regcomp($kid, 1, $extended);
3776     }
3777     $flags .= "e" if $op->pmflags & PMf_EVAL;
3778     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3779     $flags .= "i" if $op->pmflags & PMf_FOLD;
3780     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3781     $flags .= "o" if $op->pmflags & PMf_KEEP;
3782     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3783     $flags .= "x" if $extended;
3784     $flags = $substwords{$flags} if $substwords{$flags};
3785     if ($binop) {
3786         return $self->maybe_parens("$var =~ s"
3787                                    . double_delim($re, $repl) . $flags,
3788                                    $cx, 20);
3789     } else {
3790         return "s". double_delim($re, $repl) . $flags;
3791     }
3792 }
3793
3794 1;
3795 __END__
3796
3797 =head1 NAME
3798
3799 B::Deparse - Perl compiler backend to produce perl code
3800
3801 =head1 SYNOPSIS
3802
3803 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3804         [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3805
3806 =head1 DESCRIPTION
3807
3808 B::Deparse is a backend module for the Perl compiler that generates
3809 perl source code, based on the internal compiled structure that perl
3810 itself creates after parsing a program. The output of B::Deparse won't
3811 be exactly the same as the original source, since perl doesn't keep
3812 track of comments or whitespace, and there isn't a one-to-one
3813 correspondence between perl's syntactical constructions and their
3814 compiled form, but it will often be close. When you use the B<-p>
3815 option, the output also includes parentheses even when they are not
3816 required by precedence, which can make it easy to see if perl is
3817 parsing your expressions the way you intended.
3818
3819 Please note that this module is mainly new and untested code and is
3820 still under development, so it may change in the future.
3821
3822 =head1 OPTIONS
3823
3824 As with all compiler backend options, these must follow directly after
3825 the '-MO=Deparse', separated by a comma but not any white space.
3826
3827 =over 4
3828
3829 =item B<-l>
3830
3831 Add '#line' declarations to the output based on the line and file
3832 locations of the original code.
3833
3834 =item B<-p>
3835
3836 Print extra parentheses. Without this option, B::Deparse includes
3837 parentheses in its output only when they are needed, based on the
3838 structure of your program. With B<-p>, it uses parentheses (almost)
3839 whenever they would be legal. This can be useful if you are used to
3840 LISP, or if you want to see how perl parses your input. If you say
3841
3842     if ($var & 0x7f == 65) {print "Gimme an A!"}
3843     print ($which ? $a : $b), "\n";
3844     $name = $ENV{USER} or "Bob";
3845
3846 C<B::Deparse,-p> will print
3847
3848     if (($var & 0)) {
3849         print('Gimme an A!')
3850     };
3851     (print(($which ? $a : $b)), '???');
3852     (($name = $ENV{'USER'}) or '???')
3853
3854 which probably isn't what you intended (the C<'???'> is a sign that
3855 perl optimized away a constant value).
3856
3857 =item B<-P>
3858
3859 Disable prototype checking. With this option, all function calls are
3860 deparsed as if no prototype was defined for them. In other words,
3861
3862     perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
3863
3864 will print
3865
3866     sub foo (\@) {
3867         1;
3868     }
3869     &foo(\@x);
3870
3871 making clear how the parameters are actually passed to C<foo>.
3872
3873 =item B<-q>
3874
3875 Expand double-quoted strings into the corresponding combinations of
3876 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3877 instance, print
3878
3879     print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3880
3881 as
3882
3883     print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3884           . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3885
3886 Note that the expanded form represents the way perl handles such
3887 constructions internally -- this option actually turns off the reverse
3888 translation that B::Deparse usually does. On the other hand, note that
3889 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3890 of $y into a string before doing the assignment.
3891
3892 =item B<-f>I<FILE>
3893
3894 Normally, B::Deparse deparses the main code of a program, and all the subs
3895 defined in the same file. To include subs defined in other files, pass the
3896 B<-f> option with the filename. You can pass the B<-f> option several times, to
3897 include more than one secondary file.  (Most of the time you don't want to
3898 use it at all.)  You can also use this option to include subs which are
3899 defined in the scope of a B<#line> directive with two parameters.
3900
3901 =item B<-s>I<LETTERS>
3902
3903 Tweak the style of B::Deparse's output. The letters should follow
3904 directly after the 's', with no space or punctuation. The following
3905 options are available:
3906
3907 =over 4
3908
3909 =item B<C>
3910
3911 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3912
3913     if (...) {
3914          ...
3915     } else {
3916          ...
3917     }
3918
3919 instead of
3920
3921     if (...) {
3922          ...
3923     }
3924     else {
3925          ...
3926     }
3927
3928 The default is not to cuddle.
3929
3930 =item B<i>I<NUMBER>
3931
3932 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3933
3934 =item B<T>
3935
3936 Use tabs for each 8 columns of indent. The default is to use only spaces.
3937 For instance, if the style options are B<-si4T>, a line that's indented
3938 3 times will be preceded by one tab and four spaces; if the options were
3939 B<-si8T>, the same line would be preceded by three tabs.
3940
3941 =item B<v>I<STRING>B<.>
3942
3943 Print I<STRING> for the value of a constant that can't be determined
3944 because it was optimized away (mnemonic: this happens when a constant
3945 is used in B<v>oid context). The end of the string is marked by a period.
3946 The string should be a valid perl expression, generally a constant.
3947 Note that unless it's a number, it probably needs to be quoted, and on
3948 a command line quotes need to be protected from the shell. Some
3949 conventional values include 0, 1, 42, '', 'foo', and
3950 'Useless use of constant omitted' (which may need to be
3951 B<-sv"'Useless use of constant omitted'.">
3952 or something similar depending on your shell). The default is '???'.
3953 If you're using B::Deparse on a module or other file that's require'd,
3954 you shouldn't use a value that evaluates to false, since the customary
3955 true constant at the end of a module will be in void context when the
3956 file is compiled as a main program.
3957
3958 =back
3959
3960 =item B<-x>I<LEVEL>
3961
3962 Expand conventional syntax constructions into equivalent ones that expose
3963 their internal operation. I<LEVEL> should be a digit, with higher values
3964 meaning more expansion. As with B<-q>, this actually involves turning off
3965 special cases in B::Deparse's normal operations.
3966
3967 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3968 while loops with continue blocks; for instance
3969
3970     for ($i = 0; $i < 10; ++$i) {
3971         print $i;
3972     }
3973
3974 turns into
3975
3976     $i = 0;
3977     while ($i < 10) {
3978         print $i;
3979     } continue {
3980         ++$i
3981     }
3982
3983 Note that in a few cases this translation can't be perfectly carried back
3984 into the source code -- if the loop's initializer declares a my variable,
3985 for instance, it won't have the correct scope outside of the loop.
3986
3987 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3988 expressions using C<&&>, C<?:> and C<do {}>; for instance
3989
3990     print 'hi' if $nice;
3991     if ($nice) {
3992         print 'hi';
3993     }
3994     if ($nice) {
3995         print 'hi';
3996     } else {
3997         print 'bye';
3998     }
3999
4000 turns into
4001
4002     $nice and print 'hi';
4003     $nice and do { print 'hi' };
4004     $nice ? do { print 'hi' } : do { print 'bye' };
4005
4006 Long sequences of elsifs will turn into nested ternary operators, which
4007 B::Deparse doesn't know how to indent nicely.
4008
4009 =back
4010
4011 =head1 USING B::Deparse AS A MODULE
4012
4013 =head2 Synopsis
4014
4015     use B::Deparse;
4016     $deparse = B::Deparse->new("-p", "-sC");
4017     $body = $deparse->coderef2text(\&func);
4018     eval "sub func $body"; # the inverse operation
4019
4020 =head2 Description
4021
4022 B::Deparse can also be used on a sub-by-sub basis from other perl
4023 programs.
4024
4025 =head2 new
4026
4027     $deparse = B::Deparse->new(OPTIONS)
4028
4029 Create an object to store the state of a deparsing operation and any
4030 options. The options are the same as those that can be given on the
4031 command line (see L</OPTIONS>); options that are separated by commas
4032 after B<-MO=Deparse> should be given as separate strings. Some
4033 options, like B<-u>, don't make sense for a single subroutine, so
4034 don't pass them.
4035
4036 =head2 ambient_pragmas
4037
4038     $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
4039
4040 The compilation of a subroutine can be affected by a few compiler
4041 directives, B<pragmas>. These are:
4042
4043 =over 4
4044
4045 =item *
4046
4047 use strict;
4048
4049 =item *
4050
4051 use warnings;
4052
4053 =item *
4054
4055 Assigning to the special variable $[
4056
4057 =item *
4058
4059 use integer;
4060
4061 =item *
4062
4063 use bytes;
4064
4065 =item *
4066
4067 use utf8;
4068
4069 =item *
4070
4071 use re;
4072
4073 =back
4074
4075 Ordinarily, if you use B::Deparse on a subroutine which has
4076 been compiled in the presence of one or more of these pragmas,
4077 the output will include statements to turn on the appropriate
4078 directives. So if you then compile the code returned by coderef2text,
4079 it will behave the same way as the subroutine which you deparsed.
4080
4081 However, you may know that you intend to use the results in a
4082 particular context, where some pragmas are already in scope. In
4083 this case, you use the B<ambient_pragmas> method to describe the
4084 assumptions you wish to make.
4085
4086 Not all of the options currently have any useful effect. See
4087 L</BUGS> for more details.
4088
4089 The parameters it accepts are:
4090
4091 =over 4
4092
4093 =item strict
4094
4095 Takes a string, possibly containing several values separated
4096 by whitespace. The special values "all" and "none" mean what you'd
4097 expect.
4098
4099     $deparse->ambient_pragmas(strict => 'subs refs');
4100
4101 =item $[
4102
4103 Takes a number, the value of the array base $[.
4104
4105 =item bytes
4106
4107 =item utf8
4108
4109 =item integer
4110
4111 If the value is true, then the appropriate pragma is assumed to
4112 be in the ambient scope, otherwise not.
4113
4114 =item re
4115
4116 Takes a string, possibly containing a whitespace-separated list of
4117 values. The values "all" and "none" are special. It's also permissible
4118 to pass an array reference here.
4119
4120     $deparser->ambient_pragmas(re => 'eval');
4121
4122
4123 =item warnings
4124
4125 Takes a string, possibly containing a whitespace-separated list of
4126 values. The values "all" and "none" are special, again. It's also
4127 permissible to pass an array reference here.
4128
4129     $deparser->ambient_pragmas(warnings => [qw[void io]]);
4130
4131 If one of the values is the string "FATAL", then all the warnings
4132 in that list will be considered fatal, just as with the B<warnings>
4133 pragma itself. Should you need to specify that some warnings are
4134 fatal, and others are merely enabled, you can pass the B<warnings>
4135 parameter twice:
4136
4137     $deparser->ambient_pragmas(
4138         warnings => 'all',
4139         warnings => [FATAL => qw/void io/],
4140     );
4141
4142 See L<perllexwarn> for more information about lexical warnings.
4143
4144 =item hint_bits
4145
4146 =item warning_bits
4147
4148 These two parameters are used to specify the ambient pragmas in
4149 the format used by the special variables $^H and ${^WARNING_BITS}.
4150
4151 They exist principally so that you can write code like:
4152
4153     { my ($hint_bits, $warning_bits);
4154     BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
4155     $deparser->ambient_pragmas (
4156         hint_bits    => $hint_bits,
4157         warning_bits => $warning_bits,
4158         '$['         => 0 + $[
4159     ); }
4160
4161 which specifies that the ambient pragmas are exactly those which
4162 are in scope at the point of calling.
4163
4164 =back
4165
4166 =head2 coderef2text
4167
4168     $body = $deparse->coderef2text(\&func)
4169     $body = $deparse->coderef2text(sub ($$) { ... })
4170
4171 Return source code for the body of a subroutine (a block, optionally
4172 preceded by a prototype in parens), given a reference to the
4173 sub. Because a subroutine can have no names, or more than one name,
4174 this method doesn't return a complete subroutine definition -- if you
4175 want to eval the result, you should prepend "sub subname ", or "sub "
4176 for an anonymous function constructor. Unless the sub was defined in
4177 the main:: package, the code will include a package declaration.
4178
4179 =head1 BUGS
4180
4181 =over 4
4182
4183 =item *
4184
4185 The only pragmas to be completely supported are: C<use warnings>,
4186 C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
4187 behaves like a pragma, is also supported.)
4188
4189 Excepting those listed above, we're currently unable to guarantee that
4190 B::Deparse will produce a pragma at the correct point in the program.
4191 Since the effects of pragmas are often lexically scoped, this can mean
4192 that the pragma holds sway over a different portion of the program
4193 than in the input file.
4194
4195 =item *
4196
4197 In fact, the above is a specific instance of a more general problem:
4198 we can't guarantee to produce BEGIN blocks or C<use> declarations in
4199 exactly the right place. So if you use a module which affects compilation
4200 (such as by over-riding keywords, overloading constants or whatever)
4201 then the output code might not work as intended.
4202
4203 This is the most serious outstanding problem, and will be very hard
4204 to fix.
4205
4206 =item *
4207
4208 If a keyword is over-ridden, and your program explicitly calls
4209 the built-in version by using CORE::keyword, the output of B::Deparse
4210 will not reflect this. If you run the resulting code, it will call
4211 the over-ridden version rather than the built-in one. (Maybe there
4212 should be an option to B<always> print keyword calls as C<CORE::name>.)
4213
4214 =item *
4215
4216 C<sort foo (1, 2, 3)> comes out as C<sort (foo 1, 2, 3)>, which
4217 causes perl to issue a warning.
4218
4219 The obvious fix doesn't work, because these are different:
4220
4221     print (FOO 1, 2, 3), 4, 5, 6;
4222     print FOO (1, 2, 3), 4, 5, 6;
4223
4224 =item *
4225
4226 Constants (other than simple strings or numbers) don't work properly.
4227 Pathological examples that fail (and probably always will) include:
4228
4229     use constant E2BIG => ($!=7);
4230     use constant x=>\$x; print x
4231
4232 The following could (and should) be made to work:
4233
4234     use constant regex => qr/blah/;
4235     print regex;
4236
4237 =item *
4238
4239 An input file that uses source filtering probably won't be deparsed into
4240 runnable code, because it will still include the B<use> declaration
4241 for the source filtering module, even though the code that is
4242 produced is already ordinary Perl which shouldn't be filtered again.
4243
4244 =item *
4245
4246 There are probably many more bugs on non-ASCII platforms (EBCDIC).
4247
4248 =back
4249
4250 =head1 AUTHOR
4251
4252 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
4253 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
4254 contributions from Gisle Aas, James Duncan, Albert Dvornik, Robin
4255 Houston, Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons,
4256 and Rafael Garcia-Suarez.
4257
4258 =cut