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