ext/B/B/Deparse.pm

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