ext/B/B/Deparse.pm

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