dist/B-Deparse/Deparse.pm

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