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