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