ext/B/B/Deparse.pm

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