dist/B-Deparse/Deparse.pm

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