ext/B/B/Deparse.pm

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