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