dist/B-Deparse/Deparse.pm

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