dist/B-Deparse/Deparse.pm

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