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