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_say  { indirop(@_, "say") }
2417 sub pp_sort { indirop(@_, "sort") }
2418
2419 sub mapop {
2420     my $self = shift;
2421     my($op, $cx, $name) = @_;
2422     my($expr, @exprs);
2423     my $kid = $op->first; # this is the (map|grep)start
2424     $kid = $kid->first->sibling; # skip a pushmark
2425     my $code = $kid->first; # skip a null
2426     if (is_scope $code) {
2427         $code = "{" . $self->deparse($code, 0) . "} ";
2428     } else {
2429         $code = $self->deparse($code, 24) . ", ";
2430     }
2431     $kid = $kid->sibling;
2432     for (; !null($kid); $kid = $kid->sibling) {
2433         $expr = $self->deparse($kid, 6);
2434         push @exprs, $expr if defined $expr;
2435     }
2436     return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2437 }
2438
2439 sub pp_mapwhile { mapop(@_, "map") }
2440 sub pp_grepwhile { mapop(@_, "grep") }
2441 sub pp_mapstart { baseop(@_, "map") }
2442 sub pp_grepstart { baseop(@_, "grep") }
2443
2444 sub pp_list {
2445     my $self = shift;
2446     my($op, $cx) = @_;
2447     my($expr, @exprs);
2448     my $kid = $op->first->sibling; # skip pushmark
2449     my $lop;
2450     my $local = "either"; # could be local(...), my(...), state(...) or our(...)
2451     for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2452         # This assumes that no other private flags equal 128, and that
2453         # OPs that store things other than flags in their op_private,
2454         # like OP_AELEMFAST, won't be immediate children of a list.
2455         #
2456         # OP_ENTERSUB can break this logic, so check for it.
2457         # I suspect that open and exit can too.
2458
2459         if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
2460                 or $lop->name eq "undef")
2461             or $lop->name eq "entersub"
2462             or $lop->name eq "exit"
2463             or $lop->name eq "open")
2464         {
2465             $local = ""; # or not
2466             last;
2467         }
2468         if ($lop->name =~ /^pad[ash]v$/) {
2469             if ($lop->private & OPpPAD_STATE) { # state()
2470                 ($local = "", last) if $local =~ /^(?:local|our|my)$/;
2471                 $local = "state";
2472             } else { # my()
2473                 ($local = "", last) if $local =~ /^(?:local|our|state)$/;
2474                 $local = "my";
2475             }
2476         } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
2477                         && $lop->private & OPpOUR_INTRO
2478                 or $lop->name eq "null" && $lop->first->name eq "gvsv"
2479                         && $lop->first->private & OPpOUR_INTRO) { # our()
2480             ($local = "", last) if $local =~ /^(?:my|local|state)$/;
2481             $local = "our";
2482         } elsif ($lop->name ne "undef"
2483                 # specifically avoid the "reverse sort" optimisation,
2484                 # where "reverse" is nullified
2485                 && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
2486         {
2487             # local()
2488             ($local = "", last) if $local =~ /^(?:my|our|state)$/;
2489             $local = "local";
2490         }
2491     }
2492     $local = "" if $local eq "either"; # no point if it's all undefs
2493     return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2494     for (; !null($kid); $kid = $kid->sibling) {
2495         if ($local) {
2496             if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2497                 $lop = $kid->first;
2498             } else {
2499                 $lop = $kid;
2500             }
2501             $self->{'avoid_local'}{$$lop}++;
2502             $expr = $self->deparse($kid, 6);
2503             delete $self->{'avoid_local'}{$$lop};
2504         } else {
2505             $expr = $self->deparse($kid, 6);
2506         }
2507         push @exprs, $expr;
2508     }
2509     if ($local) {
2510         return "$local(" . join(", ", @exprs) . ")";
2511     } else {
2512         return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2513     }
2514 }
2515
2516 sub is_ifelse_cont {
2517     my $op = shift;
2518     return ($op->name eq "null" and class($op) eq "UNOP"
2519             and $op->first->name =~ /^(and|cond_expr)$/
2520             and is_scope($op->first->first->sibling));
2521 }
2522
2523 sub pp_cond_expr {
2524     my $self = shift;
2525     my($op, $cx) = @_;
2526     my $cond = $op->first;
2527     my $true = $cond->sibling;
2528     my $false = $true->sibling;
2529     my $cuddle = $self->{'cuddle'};
2530     unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
2531             (is_scope($false) || is_ifelse_cont($false))
2532             and $self->{'expand'} < 7) {
2533         $cond = $self->deparse($cond, 8);
2534         $true = $self->deparse($true, 6);
2535         $false = $self->deparse($false, 8);
2536         return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2537     }
2538
2539     $cond = $self->deparse($cond, 1);
2540     $true = $self->deparse($true, 0);
2541     my $head = "if ($cond) {\n\t$true\n\b}";
2542     my @elsifs;
2543     while (!null($false) and is_ifelse_cont($false)) {
2544         my $newop = $false->first;
2545         my $newcond = $newop->first;
2546         my $newtrue = $newcond->sibling;
2547         $false = $newtrue->sibling; # last in chain is OP_AND => no else
2548         $newcond = $self->deparse($newcond, 1);
2549         $newtrue = $self->deparse($newtrue, 0);
2550         push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2551     }
2552     if (!null($false)) {
2553         $false = $cuddle . "else {\n\t" .
2554           $self->deparse($false, 0) . "\n\b}\cK";
2555     } else {
2556         $false = "\cK";
2557     }
2558     return $head . join($cuddle, "", @elsifs) . $false;
2559 }
2560
2561 sub pp_once {
2562     my ($self, $op, $cx) = @_;
2563     my $cond = $op->first;
2564     my $true = $cond->sibling;
2565
2566     return $self->deparse($true, $cx);
2567 }
2568
2569 sub loop_common {
2570     my $self = shift;
2571     my($op, $cx, $init) = @_;
2572     my $enter = $op->first;
2573     my $kid = $enter->sibling;
2574     local(@$self{qw'curstash warnings hints'})
2575                 = @$self{qw'curstash warnings hints'};
2576     my $head = "";
2577     my $bare = 0;
2578     my $body;
2579     my $cond = undef;
2580     if ($kid->name eq "lineseq") { # bare or infinite loop
2581         if ($kid->last->name eq "unstack") { # infinite
2582             $head = "while (1) "; # Can't use for(;;) if there's a continue
2583             $cond = "";
2584         } else {
2585             $bare = 1;
2586         }
2587         $body = $kid;
2588     } elsif ($enter->name eq "enteriter") { # foreach
2589         my $ary = $enter->first->sibling; # first was pushmark
2590         my $var = $ary->sibling;
2591         if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
2592             # "reverse" was optimised away
2593             $ary = listop($self, $ary->first->sibling, 1, 'reverse');
2594         } elsif ($enter->flags & OPf_STACKED
2595             and not null $ary->first->sibling->sibling)
2596         {
2597             $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2598               $self->deparse($ary->first->sibling->sibling, 9);
2599         } else {
2600             $ary = $self->deparse($ary, 1);
2601         }
2602         if (null $var) {
2603             if ($enter->flags & OPf_SPECIAL) { # thread special var
2604                 $var = $self->pp_threadsv($enter, 1);
2605             } else { # regular my() variable
2606                 $var = $self->pp_padsv($enter, 1);
2607             }
2608         } elsif ($var->name eq "rv2gv") {
2609             $var = $self->pp_rv2sv($var, 1);
2610             if ($enter->private & OPpOUR_INTRO) {
2611                 # our declarations don't have package names
2612                 $var =~ s/^(.).*::/$1/;
2613                 $var = "our $var";
2614             }
2615         } elsif ($var->name eq "gv") {
2616             $var = "\$" . $self->deparse($var, 1);
2617         }
2618         $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2619         if (!is_state $body->first and $body->first->name ne "stub") {
2620             confess unless $var eq '$_';
2621             $body = $body->first;
2622             return $self->deparse($body, 2) . " foreach ($ary)";
2623         }
2624         $head = "foreach $var ($ary) ";
2625     } elsif ($kid->name eq "null") { # while/until
2626         $kid = $kid->first;
2627         my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2628         $cond = $self->deparse($kid->first, 1);
2629         $head = "$name ($cond) ";
2630         $body = $kid->first->sibling;
2631     } elsif ($kid->name eq "stub") { # bare and empty
2632         return "{;}"; # {} could be a hashref
2633     }
2634     # If there isn't a continue block, then the next pointer for the loop
2635     # will point to the unstack, which is kid's last child, except
2636     # in a bare loop, when it will point to the leaveloop. When neither of
2637     # these conditions hold, then the second-to-last child is the continue
2638     # block (or the last in a bare loop).
2639     my $cont_start = $enter->nextop;
2640     my $cont;
2641     if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
2642         if ($bare) {
2643             $cont = $body->last;
2644         } else {
2645             $cont = $body->first;
2646             while (!null($cont->sibling->sibling)) {
2647                 $cont = $cont->sibling;
2648             }
2649         }
2650         my $state = $body->first;
2651         my $cuddle = $self->{'cuddle'};
2652         my @states;
2653         for (; $$state != $$cont; $state = $state->sibling) {
2654             push @states, $state;
2655         }
2656         $body = $self->lineseq(undef, @states);
2657         if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2658             $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2659             $cont = "\cK";
2660         } else {
2661             $cont = $cuddle . "continue {\n\t" .
2662               $self->deparse($cont, 0) . "\n\b}\cK";
2663         }
2664     } else {
2665         return "" if !defined $body;
2666         if (length $init) {
2667             $head = "for ($init; $cond;) ";
2668         }
2669         $cont = "\cK";
2670         $body = $self->deparse($body, 0);
2671     }
2672     $body =~ s/;?$/;\n/;
2673
2674     return $head . "{\n\t" . $body . "\b}" . $cont;
2675 }
2676
2677 sub pp_leaveloop { shift->loop_common(@_, "") }
2678
2679 sub for_loop {
2680     my $self = shift;
2681     my($op, $cx) = @_;
2682     my $init = $self->deparse($op, 1);
2683     return $self->loop_common($op->sibling->first->sibling, $cx, $init);
2684 }
2685
2686 sub pp_leavetry {
2687     my $self = shift;
2688     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2689 }
2690
2691 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2692 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2693 BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
2694 BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
2695
2696 sub pp_null {
2697     my $self = shift;
2698     my($op, $cx) = @_;
2699     if (class($op) eq "OP") {
2700         # old value is lost
2701         return $self->{'ex_const'} if $op->targ == OP_CONST;
2702     } elsif ($op->first->name eq "pushmark") {
2703         return $self->pp_list($op, $cx);
2704     } elsif ($op->first->name eq "enter") {
2705         return $self->pp_leave($op, $cx);
2706     } elsif ($op->first->name eq "leave") {
2707         return $self->pp_leave($op->first, $cx);
2708     } elsif ($op->first->name eq "scope") {
2709         return $self->pp_scope($op->first, $cx);
2710     } elsif ($op->targ == OP_STRINGIFY) {
2711         return $self->dquote($op, $cx);
2712     } elsif (!null($op->first->sibling) and
2713              $op->first->sibling->name eq "readline" and
2714              $op->first->sibling->flags & OPf_STACKED) {
2715         return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2716                                    . $self->deparse($op->first->sibling, 7),
2717                                    $cx, 7);
2718     } elsif (!null($op->first->sibling) and
2719              $op->first->sibling->name eq "trans" and
2720              $op->first->sibling->flags & OPf_STACKED) {
2721         return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2722                                    . $self->deparse($op->first->sibling, 20),
2723                                    $cx, 20);
2724     } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
2725         return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
2726     } elsif (!null($op->first->sibling) and
2727              $op->first->sibling->name eq "null" and
2728              class($op->first->sibling) eq "UNOP" and
2729              $op->first->sibling->first->flags & OPf_STACKED and
2730              $op->first->sibling->first->name eq "rcatline") {
2731         return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
2732                                    . $self->deparse($op->first->sibling, 18),
2733                                    $cx, 18);
2734     } else {
2735         return $self->deparse($op->first, $cx);
2736     }
2737 }
2738
2739 sub padname {
2740     my $self = shift;
2741     my $targ = shift;
2742     return $self->padname_sv($targ)->PVX;
2743 }
2744
2745 sub padany {
2746     my $self = shift;
2747     my $op = shift;
2748     return substr($self->padname($op->targ), 1); # skip $/@/%
2749 }
2750
2751 sub pp_padsv {
2752     my $self = shift;
2753     my($op, $cx) = @_;
2754     return $self->maybe_my($op, $cx, $self->padname($op->targ));
2755 }
2756
2757 sub pp_padav { pp_padsv(@_) }
2758 sub pp_padhv { pp_padsv(@_) }
2759
2760 my @threadsv_names;
2761
2762 BEGIN {
2763     @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2764                        "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2765                        "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2766                        "!", "@");
2767 }
2768
2769 sub pp_threadsv {
2770     my $self = shift;
2771     my($op, $cx) = @_;
2772     return $self->maybe_local($op, $cx, "\$" .  $threadsv_names[$op->targ]);
2773 }
2774
2775 sub gv_or_padgv {
2776     my $self = shift;
2777     my $op = shift;
2778     if (class($op) eq "PADOP") {
2779         return $self->padval($op->padix);
2780     } else { # class($op) eq "SVOP"
2781         return $op->gv;
2782     }
2783 }
2784
2785 sub pp_gvsv {
2786     my $self = shift;
2787     my($op, $cx) = @_;
2788     my $gv = $self->gv_or_padgv($op);
2789     return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2790                                  $self->gv_name($gv)));
2791 }
2792
2793 sub pp_gv {
2794     my $self = shift;
2795     my($op, $cx) = @_;
2796     my $gv = $self->gv_or_padgv($op);
2797     return $self->gv_name($gv);
2798 }
2799
2800 sub pp_aelemfast {
2801     my $self = shift;
2802     my($op, $cx) = @_;
2803     my $name;
2804     if ($op->flags & OPf_SPECIAL) { # optimised PADAV
2805         $name = $self->padname($op->targ);
2806         $name =~ s/^@/\$/;
2807     }
2808     else {
2809         my $gv = $self->gv_or_padgv($op);
2810         $name = $self->gv_name($gv);
2811         $name = $self->{'curstash'}."::$name"
2812             if $name !~ /::/ && $self->lex_in_scope('@'.$name);
2813         $name = '$' . $name;
2814     }
2815
2816     return $name . "[" .  ($op->private + $self->{'arybase'}) . "]";
2817 }
2818
2819 sub rv2x {
2820     my $self = shift;
2821     my($op, $cx, $type) = @_;
2822
2823     if (class($op) eq 'NULL' || !$op->can("first")) {
2824         carp("Unexpected op in pp_rv2x");
2825         return 'XXX';
2826     }
2827     my $kid = $op->first;
2828     if ($kid->name eq "gv") {
2829         return $self->stash_variable($type, $self->deparse($kid, 0));
2830     } elsif (is_scalar $kid) {
2831         my $str = $self->deparse($kid, 0);
2832         if ($str =~ /^\$([^\w\d])\z/) {
2833             # "$$+" isn't a legal way to write the scalar dereference
2834             # of $+, since the lexer can't tell you aren't trying to
2835             # do something like "$$ + 1" to get one more than your
2836             # PID. Either "${$+}" or "$${+}" are workable
2837             # disambiguations, but if the programmer did the former,
2838             # they'd be in the "else" clause below rather than here.
2839             # It's not clear if this should somehow be unified with
2840             # the code in dq and re_dq that also adds lexer
2841             # disambiguation braces.
2842             $str = '$' . "{$1}"; #'
2843         }
2844         return $type . $str;
2845     } else {
2846         return $type . "{" . $self->deparse($kid, 0) . "}";
2847     }
2848 }
2849
2850 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2851 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2852 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2853
2854 # skip rv2av
2855 sub pp_av2arylen {
2856     my $self = shift;
2857     my($op, $cx) = @_;
2858     if ($op->first->name eq "padav") {
2859         return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2860     } else {
2861         return $self->maybe_local($op, $cx,
2862                                   $self->rv2x($op->first, $cx, '$#'));
2863     }
2864 }
2865
2866 # skip down to the old, ex-rv2cv
2867 sub pp_rv2cv {
2868     my ($self, $op, $cx) = @_;
2869     if (!null($op->first) && $op->first->name eq 'null' &&
2870         $op->first->targ eq OP_LIST)
2871     {
2872         return $self->rv2x($op->first->first->sibling, $cx, "&")
2873     }
2874     else {
2875         return $self->rv2x($op, $cx, "")
2876     }
2877 }
2878
2879 sub list_const {
2880     my $self = shift;
2881     my($cx, @list) = @_;
2882     my @a = map $self->const($_, 6), @list;
2883     if (@a == 0) {
2884         return "()";
2885     } elsif (@a == 1) {
2886         return $a[0];
2887     } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
2888         # collapse (-1,0,1,2) into (-1..2)
2889         my ($s, $e) = @a[0,-1];
2890         my $i = $s;
2891         return $self->maybe_parens("$s..$e", $cx, 9)
2892           unless grep $i++ != $_, @a;
2893     }
2894     return $self->maybe_parens(join(", ", @a), $cx, 6);
2895 }
2896
2897 sub pp_rv2av {
2898     my $self = shift;
2899     my($op, $cx) = @_;
2900     my $kid = $op->first;
2901     if ($kid->name eq "const") { # constant list
2902         my $av = $self->const_sv($kid);
2903         return $self->list_const($cx, $av->ARRAY);
2904     } else {
2905         return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2906     }
2907  }
2908
2909 sub is_subscriptable {
2910     my $op = shift;
2911     if ($op->name =~ /^[ahg]elem/) {
2912         return 1;
2913     } elsif ($op->name eq "entersub") {
2914         my $kid = $op->first;
2915         return 0 unless null $kid->sibling;
2916         $kid = $kid->first;
2917         $kid = $kid->sibling until null $kid->sibling;
2918         return 0 if is_scope($kid);
2919         $kid = $kid->first;
2920         return 0 if $kid->name eq "gv";
2921         return 0 if is_scalar($kid);
2922         return is_subscriptable($kid);
2923     } else {
2924         return 0;
2925     }
2926 }
2927
2928 sub elem_or_slice_array_name
2929 {
2930     my $self = shift;
2931     my ($array, $left, $padname, $allow_arrow) = @_;
2932
2933     if ($array->name eq $padname) {
2934         return $self->padany($array);
2935     } elsif (is_scope($array)) { # ${expr}[0]
2936         return "{" . $self->deparse($array, 0) . "}";
2937     } elsif ($array->name eq "gv") {
2938         $array = $self->gv_name($self->gv_or_padgv($array));
2939         if ($array !~ /::/) {
2940             my $prefix = ($left eq '[' ? '@' : '%');
2941             $array = $self->{curstash}.'::'.$array
2942                 if $self->lex_in_scope($prefix . $array);
2943         }
2944         return $array;
2945     } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
2946         return $self->deparse($array, 24);
2947     } else {
2948         return undef;
2949     }
2950 }
2951
2952 sub elem_or_slice_single_index
2953 {
2954     my $self = shift;
2955     my ($idx) = @_;
2956
2957     $idx = $self->deparse($idx, 1);
2958
2959     # Outer parens in an array index will confuse perl
2960     # if we're interpolating in a regular expression, i.e.
2961     # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2962     #
2963     # If $self->{parens}, then an initial '(' will
2964     # definitely be paired with a final ')'. If
2965     # !$self->{parens}, the misleading parens won't
2966     # have been added in the first place.
2967     #
2968     # [You might think that we could get "(...)...(...)"
2969     # where the initial and final parens do not match
2970     # each other. But we can't, because the above would
2971     # only happen if there's an infix binop between the
2972     # two pairs of parens, and *that* means that the whole
2973     # expression would be parenthesized as well.]
2974     #
2975     $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2976
2977     # Hash-element braces will autoquote a bareword inside themselves.
2978     # We need to make sure that C<$hash{warn()}> doesn't come out as
2979     # C<$hash{warn}>, which has a quite different meaning. Currently
2980     # B::Deparse will always quote strings, even if the string was a
2981     # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
2982     # for constant strings.) So we can cheat slightly here - if we see
2983     # a bareword, we know that it is supposed to be a function call.
2984     #
2985     $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
2986
2987     return $idx;
2988 }
2989
2990 sub elem {
2991     my $self = shift;
2992     my ($op, $cx, $left, $right, $padname) = @_;
2993     my($array, $idx) = ($op->first, $op->first->sibling);
2994
2995     $idx = $self->elem_or_slice_single_index($idx);
2996
2997     unless ($array->name eq $padname) { # Maybe this has been fixed
2998         $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2999     }
3000     if (my $array_name=$self->elem_or_slice_array_name
3001             ($array, $left, $padname, 1)) {
3002         return "\$" . $array_name . $left . $idx . $right;
3003     } else {
3004         # $x[20][3]{hi} or expr->[20]
3005         my $arrow = is_subscriptable($array) ? "" : "->";
3006         return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
3007     }
3008
3009 }
3010
3011 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
3012 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
3013
3014 sub pp_gelem {
3015     my $self = shift;
3016     my($op, $cx) = @_;
3017     my($glob, $part) = ($op->first, $op->last);
3018     $glob = $glob->first; # skip rv2gv
3019     $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
3020     my $scope = is_scope($glob);
3021     $glob = $self->deparse($glob, 0);
3022     $part = $self->deparse($part, 1);
3023     return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
3024 }
3025
3026 sub slice {
3027     my $self = shift;
3028     my ($op, $cx, $left, $right, $regname, $padname) = @_;
3029     my $last;
3030     my(@elems, $kid, $array, $list);
3031     if (class($op) eq "LISTOP") {
3032         $last = $op->last;
3033     } else { # ex-hslice inside delete()
3034         for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
3035         $last = $kid;
3036     }
3037     $array = $last;
3038     $array = $array->first
3039         if $array->name eq $regname or $array->name eq "null";
3040     $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
3041     $kid = $op->first->sibling; # skip pushmark
3042     if ($kid->name eq "list") {
3043         $kid = $kid->first->sibling; # skip list, pushmark
3044         for (; !null $kid; $kid = $kid->sibling) {
3045             push @elems, $self->deparse($kid, 6);
3046         }
3047         $list = join(", ", @elems);
3048     } else {
3049         $list = $self->elem_or_slice_single_index($kid);
3050     }
3051     return "\@" . $array . $left . $list . $right;
3052 }
3053
3054 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
3055 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
3056
3057 sub pp_lslice {
3058     my $self = shift;
3059     my($op, $cx) = @_;
3060     my $idx = $op->first;
3061     my $list = $op->last;
3062     my(@elems, $kid);
3063     $list = $self->deparse($list, 1);
3064     $idx = $self->deparse($idx, 1);
3065     return "($list)" . "[$idx]";
3066 }
3067
3068 sub want_scalar {
3069     my $op = shift;
3070     return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
3071 }
3072
3073 sub want_list {
3074     my $op = shift;
3075     return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
3076 }
3077
3078 sub _method {
3079     my $self = shift;
3080     my($op, $cx) = @_;
3081     my $kid = $op->first->sibling; # skip pushmark
3082     my($meth, $obj, @exprs);
3083     if ($kid->name eq "list" and want_list $kid) {
3084         # When an indirect object isn't a bareword but the args are in
3085         # parens, the parens aren't part of the method syntax (the LLAFR
3086         # doesn't apply), but they make a list with OPf_PARENS set that
3087         # doesn't get flattened by the append_elem that adds the method,
3088         # making a (object, arg1, arg2, ...) list where the object
3089         # usually is. This can be distinguished from
3090         # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
3091         # object) because in the later the list is in scalar context
3092         # as the left side of -> always is, while in the former
3093         # the list is in list context as method arguments always are.
3094         # (Good thing there aren't method prototypes!)
3095         $meth = $kid->sibling;
3096         $kid = $kid->first->sibling; # skip pushmark
3097         $obj = $kid;
3098         $kid = $kid->sibling;
3099         for (; not null $kid; $kid = $kid->sibling) {
3100             push @exprs, $kid;
3101         }
3102     } else {
3103         $obj = $kid;
3104         $kid = $kid->sibling;
3105         for (; !null ($kid->sibling) && $kid->name ne "method_named";
3106               $kid = $kid->sibling) {
3107             push @exprs, $kid
3108         }
3109         $meth = $kid;
3110     }
3111
3112     if ($meth->name eq "method_named") {
3113         $meth = $self->const_sv($meth)->PV;
3114     } else {
3115         $meth = $meth->first;
3116         if ($meth->name eq "const") {
3117             # As of 5.005_58, this case is probably obsoleted by the
3118             # method_named case above
3119             $meth = $self->const_sv($meth)->PV; # needs to be bare
3120         }
3121     }
3122
3123     return { method => $meth, variable_method => ref($meth),
3124              object => $obj, args => \@exprs  };
3125 }
3126
3127 # compat function only
3128 sub method {
3129     my $self = shift;
3130     my $info = $self->_method(@_);
3131     return $self->e_method( $self->_method(@_) );
3132 }
3133
3134 sub e_method {
3135     my ($self, $info) = @_;
3136     my $obj = $self->deparse($info->{object}, 24);
3137
3138     my $meth = $info->{method};
3139     $meth = $self->deparse($meth, 1) if $info->{variable_method};
3140     my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
3141     my $kid = $obj . "->" . $meth;
3142     if (length $args) {
3143         return $kid . "(" . $args . ")"; # parens mandatory
3144     } else {
3145         return $kid;
3146     }
3147 }
3148
3149 # returns "&" if the prototype doesn't match the args,
3150 # or ("", $args_after_prototype_demunging) if it does.
3151 sub check_proto {
3152     my $self = shift;
3153     return "&" if $self->{'noproto'};
3154     my($proto, @args) = @_;
3155     my($arg, $real);
3156     my $doneok = 0;
3157     my @reals;
3158     # An unbackslashed @ or % gobbles up the rest of the args
3159     1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
3160     while ($proto) {
3161         $proto =~ s/^(\\?[\$\@&%*]|\\\[[\$\@&%*]+\]|;)//;
3162         my $chr = $1;
3163         if ($chr eq "") {
3164             return "&" if @args;
3165         } elsif ($chr eq ";") {
3166             $doneok = 1;
3167         } elsif ($chr eq "@" or $chr eq "%") {
3168             push @reals, map($self->deparse($_, 6), @args);
3169             @args = ();
3170         } else {
3171             $arg = shift @args;
3172             last unless $arg;
3173             if ($chr eq "\$") {
3174                 if (want_scalar $arg) {
3175                     push @reals, $self->deparse($arg, 6);
3176                 } else {
3177                     return "&";
3178                 }
3179             } elsif ($chr eq "&") {
3180                 if ($arg->name =~ /^(s?refgen|undef)$/) {
3181                     push @reals, $self->deparse($arg, 6);
3182                 } else {
3183                     return "&";
3184                 }
3185             } elsif ($chr eq "*") {
3186                 if ($arg->name =~ /^s?refgen$/
3187                     and $arg->first->first->name eq "rv2gv")
3188                   {
3189                       $real = $arg->first->first; # skip refgen, null
3190                       if ($real->first->name eq "gv") {
3191                           push @reals, $self->deparse($real, 6);
3192                       } else {
3193                           push @reals, $self->deparse($real->first, 6);
3194                       }
3195                   } else {
3196                       return "&";
3197                   }
3198             } elsif (substr($chr, 0, 1) eq "\\") {
3199                 $chr =~ tr/\\[]//d;
3200                 if ($arg->name =~ /^s?refgen$/ and
3201                     !null($real = $arg->first) and
3202                     ($chr =~ /\$/ && is_scalar($real->first)
3203                      or ($chr =~ /@/
3204                          && class($real->first->sibling) ne 'NULL'
3205                          && $real->first->sibling->name
3206                          =~ /^(rv2|pad)av$/)
3207                      or ($chr =~ /%/
3208                          && class($real->first->sibling) ne 'NULL'
3209                          && $real->first->sibling->name
3210                          =~ /^(rv2|pad)hv$/)
3211                      #or ($chr =~ /&/ # This doesn't work
3212                      #   && $real->first->name eq "rv2cv")
3213                      or ($chr =~ /\*/
3214                          && $real->first->name eq "rv2gv")))
3215                   {
3216                       push @reals, $self->deparse($real, 6);
3217                   } else {
3218                       return "&";
3219                   }
3220             }
3221        }
3222     }
3223     return "&" if $proto and !$doneok; # too few args and no `;'
3224     return "&" if @args;               # too many args
3225     return ("", join ", ", @reals);
3226 }
3227
3228 sub pp_entersub {
3229     my $self = shift;
3230     my($op, $cx) = @_;
3231     return $self->e_method($self->_method($op, $cx))
3232         unless null $op->first->sibling;
3233     my $prefix = "";
3234     my $amper = "";
3235     my($kid, @exprs);
3236     if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
3237         $prefix = "do ";
3238     } elsif ($op->private & OPpENTERSUB_AMPER) {
3239         $amper = "&";
3240     }
3241     $kid = $op->first;
3242     $kid = $kid->first->sibling; # skip ex-list, pushmark
3243     for (; not null $kid->sibling; $kid = $kid->sibling) {
3244         push @exprs, $kid;
3245     }
3246     my $simple = 0;
3247     my $proto = undef;
3248     if (is_scope($kid)) {
3249         $amper = "&";
3250         $kid = "{" . $self->deparse($kid, 0) . "}";
3251     } elsif ($kid->first->name eq "gv") {
3252         my $gv = $self->gv_or_padgv($kid->first);
3253         if (class($gv->CV) ne "SPECIAL") {
3254             $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
3255         }
3256         $simple = 1; # only calls of named functions can be prototyped
3257         $kid = $self->deparse($kid, 24);
3258         if (!$amper) {
3259             if ($kid eq 'main::') {
3260                 $kid = '::';
3261             } elsif ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
3262                 $kid = single_delim("q", "'", $kid) . '->';
3263             }
3264         }
3265     } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
3266         $amper = "&";
3267         $kid = $self->deparse($kid, 24);
3268     } else {
3269         $prefix = "";
3270         my $arrow = is_subscriptable($kid->first) ? "" : "->";
3271         $kid = $self->deparse($kid, 24) . $arrow;
3272     }
3273
3274     # Doesn't matter how many prototypes there are, if
3275     # they haven't happened yet!
3276     my $declared;
3277     {
3278         no strict 'refs';
3279         no warnings 'uninitialized';
3280         $declared = exists $self->{'subs_declared'}{$kid}
3281             || (
3282                  defined &{ ${$self->{'curstash'}."::"}{$kid} }
3283                  && !exists
3284                      $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
3285                  && defined prototype $self->{'curstash'}."::".$kid
3286                );
3287         if (!$declared && defined($proto)) {
3288             # Avoid "too early to check prototype" warning
3289             ($amper, $proto) = ('&');
3290         }
3291     }
3292
3293     my $args;
3294     if ($declared and defined $proto and not $amper) {
3295         ($amper, $args) = $self->check_proto($proto, @exprs);
3296         if ($amper eq "&") {
3297             $args = join(", ", map($self->deparse($_, 6), @exprs));
3298         }
3299     } else {
3300         $args = join(", ", map($self->deparse($_, 6), @exprs));
3301     }
3302     if ($prefix or $amper) {
3303         if ($op->flags & OPf_STACKED) {
3304             return $prefix . $amper . $kid . "(" . $args . ")";
3305         } else {
3306             return $prefix . $amper. $kid;
3307         }
3308     } else {
3309         # glob() invocations can be translated into calls of
3310         # CORE::GLOBAL::glob with a second parameter, a number.
3311         # Reverse this.
3312         if ($kid eq "CORE::GLOBAL::glob") {
3313             $kid = "glob";
3314             $args =~ s/\s*,[^,]+$//;
3315         }
3316
3317         # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
3318         # so it must have been translated from a keyword call. Translate
3319         # it back.
3320         $kid =~ s/^CORE::GLOBAL:://;
3321
3322         my $dproto = defined($proto) ? $proto : "undefined";
3323         if (!$declared) {
3324             return "$kid(" . $args . ")";
3325         } elsif ($dproto eq "") {
3326             return $kid;
3327         } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
3328             # is_scalar is an excessively conservative test here:
3329             # really, we should be comparing to the precedence of the
3330             # top operator of $exprs[0] (ala unop()), but that would
3331             # take some major code restructuring to do right.
3332             return $self->maybe_parens_func($kid, $args, $cx, 16);
3333         } elsif ($dproto ne '$' and defined($proto) || $simple) { #'
3334             return $self->maybe_parens_func($kid, $args, $cx, 5);
3335         } else {
3336             return "$kid(" . $args . ")";
3337         }
3338     }
3339 }
3340
3341 sub pp_enterwrite { unop(@_, "write") }
3342
3343 # escape things that cause interpolation in double quotes,
3344 # but not character escapes
3345 sub uninterp {
3346     my($str) = @_;
3347     $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
3348     return $str;
3349 }
3350
3351 {
3352 my $bal;
3353 BEGIN {
3354     use re "eval";
3355     # Matches any string which is balanced with respect to {braces}
3356     $bal = qr(
3357       (?:
3358         [^\\{}]
3359       | \\\\
3360       | \\[{}]
3361       | \{(??{$bal})\}
3362       )*
3363     )x;
3364 }
3365
3366 # the same, but treat $|, $), $( and $ at the end of the string differently
3367 sub re_uninterp {
3368     my($str) = @_;
3369
3370     $str =~ s/
3371           ( ^|\G                  # $1
3372           | [^\\]
3373           )
3374
3375           (                       # $2
3376             (?:\\\\)*
3377           )
3378
3379           (                       # $3
3380             (\(\?\??\{$bal\}\))   # $4
3381           | [\$\@]
3382             (?!\||\)|\(|$)
3383           | \\[uUlLQE]
3384           )
3385
3386         /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3387
3388     return $str;
3389 }
3390
3391 # This is for regular expressions with the /x modifier
3392 # We have to leave comments unmangled.
3393 sub re_uninterp_extended {
3394     my($str) = @_;
3395
3396     $str =~ s/
3397           ( ^|\G                  # $1
3398           | [^\\]
3399           )
3400
3401           (                       # $2
3402             (?:\\\\)*
3403           )
3404
3405           (                       # $3
3406             ( \(\?\??\{$bal\}\)   # $4  (skip over (?{}) and (??{}) blocks)
3407             | \#[^\n]*            #     (skip over comments)
3408             )
3409           | [\$\@]
3410             (?!\||\)|\(|$|\s)
3411           | \\[uUlLQE]
3412           )
3413
3414         /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3415
3416     return $str;
3417 }
3418 }
3419
3420 my %unctrl = # portable to to EBCDIC
3421     (
3422      "\c@" => '\c@',    # unused
3423      "\cA" => '\cA',
3424      "\cB" => '\cB',
3425      "\cC" => '\cC',
3426      "\cD" => '\cD',
3427      "\cE" => '\cE',
3428      "\cF" => '\cF',
3429      "\cG" => '\cG',
3430      "\cH" => '\cH',
3431      "\cI" => '\cI',
3432      "\cJ" => '\cJ',
3433      "\cK" => '\cK',
3434      "\cL" => '\cL',
3435      "\cM" => '\cM',
3436      "\cN" => '\cN',
3437      "\cO" => '\cO',
3438      "\cP" => '\cP',
3439      "\cQ" => '\cQ',
3440      "\cR" => '\cR',
3441      "\cS" => '\cS',
3442      "\cT" => '\cT',
3443      "\cU" => '\cU',
3444      "\cV" => '\cV',
3445      "\cW" => '\cW',
3446      "\cX" => '\cX',
3447      "\cY" => '\cY',
3448      "\cZ" => '\cZ',
3449      "\c[" => '\c[',    # unused
3450      "\c\\" => '\c\\',  # unused
3451      "\c]" => '\c]',    # unused
3452      "\c_" => '\c_',    # unused
3453     );
3454
3455 # character escapes, but not delimiters that might need to be escaped
3456 sub escape_str { # ASCII, UTF8
3457     my($str) = @_;
3458     $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3459     $str =~ s/\a/\\a/g;
3460 #    $str =~ s/\cH/\\b/g; # \b means something different in a regex
3461     $str =~ s/\t/\\t/g;
3462     $str =~ s/\n/\\n/g;
3463     $str =~ s/\e/\\e/g;
3464     $str =~ s/\f/\\f/g;
3465     $str =~ s/\r/\\r/g;
3466     $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
3467     $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
3468     return $str;
3469 }
3470
3471 # For regexes with the /x modifier.
3472 # Leave whitespace unmangled.
3473 sub escape_extended_re {
3474     my($str) = @_;
3475     $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3476     $str =~ s/([[:^print:]])/
3477         ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
3478     $str =~ s/\n/\n\f/g;
3479     return $str;
3480 }
3481
3482 # Don't do this for regexen
3483 sub unback {
3484     my($str) = @_;
3485     $str =~ s/\\/\\\\/g;
3486     return $str;
3487 }
3488
3489 # Remove backslashes which precede literal control characters,
3490 # to avoid creating ambiguity when we escape the latter.
3491 sub re_unback {
3492     my($str) = @_;
3493
3494     # the insane complexity here is due to the behaviour of "\c\"
3495     $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
3496     return $str;
3497 }
3498
3499 sub balanced_delim {
3500     my($str) = @_;
3501     my @str = split //, $str;
3502     my($ar, $open, $close, $fail, $c, $cnt, $last_bs);
3503     for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
3504         ($open, $close) = @$ar;
3505         $fail = 0; $cnt = 0; $last_bs = 0;
3506         for $c (@str) {
3507             if ($c eq $open) {
3508                 $fail = 1 if $last_bs;
3509                 $cnt++;
3510             } elsif ($c eq $close) {
3511                 $fail = 1 if $last_bs;
3512                 $cnt--;
3513                 if ($cnt < 0) {
3514                     # qq()() isn't ")("
3515                     $fail = 1;
3516                     last;
3517                 }
3518             }
3519             $last_bs = $c eq '\\';
3520         }
3521         $fail = 1 if $cnt != 0;
3522         return ($open, "$open$str$close") if not $fail;
3523     }
3524     return ("", $str);
3525 }
3526
3527 sub single_delim {
3528     my($q, $default, $str) = @_;
3529     return "$default$str$default" if $default and index($str, $default) == -1;
3530     if ($q ne 'qr') {
3531         (my $succeed, $str) = balanced_delim($str);
3532         return "$q$str" if $succeed;
3533     }
3534     for my $delim ('/', '"', '#') {
3535         return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3536     }
3537     if ($default) {
3538         $str =~ s/$default/\\$default/g;
3539         return "$default$str$default";
3540     } else {
3541         $str =~ s[/][\\/]g;
3542         return "$q/$str/";
3543     }
3544 }
3545
3546 my $max_prec;
3547 BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
3548
3549 # Split a floating point number into an integer mantissa and a binary
3550 # exponent. Assumes you've already made sure the number isn't zero or
3551 # some weird infinity or NaN.
3552 sub split_float {
3553     my($f) = @_;
3554     my $exponent = 0;
3555     if ($f == int($f)) {
3556         while ($f % 2 == 0) {
3557             $f /= 2;
3558             $exponent++;
3559         }
3560     } else {
3561         while ($f != int($f)) {
3562             $f *= 2;
3563             $exponent--;
3564         }
3565     }
3566     my $mantissa = sprintf("%.0f", $f);
3567     return ($mantissa, $exponent);
3568 }
3569
3570 sub const {
3571     my $self = shift;
3572     my($sv, $cx) = @_;
3573     if ($self->{'use_dumper'}) {
3574         return $self->const_dumper($sv, $cx);
3575     }
3576     if (class($sv) eq "SPECIAL") {
3577         # sv_undef, sv_yes, sv_no
3578         return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1];
3579     } elsif (class($sv) eq "NULL") {
3580        return 'undef';
3581     }
3582     # convert a version object into the "v1.2.3" string in its V magic
3583     if ($sv->FLAGS & SVs_RMG) {
3584         for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
3585             return $mg->PTR if $mg->TYPE eq 'V';
3586         }
3587     }
3588
3589     if ($sv->FLAGS & SVf_IOK) {
3590         my $str = $sv->int_value;
3591         $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
3592         return $str;
3593     } elsif ($sv->FLAGS & SVf_NOK) {
3594         my $nv = $sv->NV;
3595         if ($nv == 0) {
3596             if (pack("F", $nv) eq pack("F", 0)) {
3597                 # positive zero
3598                 return "0";
3599             } else {
3600                 # negative zero
3601                 return $self->maybe_parens("-.0", $cx, 21);
3602             }
3603         } elsif (1/$nv == 0) {
3604             if ($nv > 0) {
3605                 # positive infinity
3606                 return $self->maybe_parens("9**9**9", $cx, 22);
3607             } else {
3608                 # negative infinity
3609                 return $self->maybe_parens("-9**9**9", $cx, 21);
3610             }
3611         } elsif ($nv != $nv) {
3612             # NaN
3613             if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
3614                 # the normal kind
3615                 return "sin(9**9**9)";
3616             } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
3617                 # the inverted kind
3618                 return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
3619             } else {
3620                 # some other kind
3621                 my $hex = unpack("h*", pack("F", $nv));
3622                 return qq'unpack("F", pack("h*", "$hex"))';
3623             }
3624         }
3625         # first, try the default stringification
3626         my $str = "$nv";
3627         if ($str != $nv) {
3628             # failing that, try using more precision
3629             $str = sprintf("%.${max_prec}g", $nv);
3630 #           if (pack("F", $str) ne pack("F", $nv)) {
3631             if ($str != $nv) {
3632                 # not representable in decimal with whatever sprintf()
3633                 # and atof() Perl is using here.
3634                 my($mant, $exp) = split_float($nv);
3635                 return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
3636             }
3637         }
3638         $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
3639         return $str;
3640     } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3641         my $ref = $sv->RV;
3642         if (class($ref) eq "AV") {
3643             return "[" . $self->list_const(2, $ref->ARRAY) . "]";
3644         } elsif (class($ref) eq "HV") {
3645             my %hash = $ref->ARRAY;
3646             my @elts;
3647             for my $k (sort keys %hash) {
3648                 push @elts, "$k => " . $self->const($hash{$k}, 6);
3649             }
3650             return "{" . join(", ", @elts) . "}";
3651         } elsif (class($ref) eq "CV") {
3652             return "sub " . $self->deparse_sub($ref);
3653         }
3654         if ($ref->FLAGS & SVs_SMG) {
3655             for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
3656                 if ($mg->TYPE eq 'r') {
3657                     my $re = re_uninterp(escape_str(re_unback($mg->precomp)));
3658                     return single_delim("qr", "", $re);
3659                 }
3660             }
3661         }
3662
3663         return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20);
3664     } elsif ($sv->FLAGS & SVf_POK) {
3665         my $str = $sv->PV;
3666         if ($str =~ /[[:^print:]]/) {
3667             return single_delim("qq", '"', uninterp escape_str unback $str);
3668         } else {
3669             return single_delim("q", "'", unback $str);
3670         }
3671     } else {
3672         return "undef";
3673     }
3674 }
3675
3676 sub const_dumper {
3677     my $self = shift;
3678     my($sv, $cx) = @_;
3679     my $ref = $sv->object_2svref();
3680     my $dumper = Data::Dumper->new([$$ref], ['$v']);
3681     $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
3682     my $str = $dumper->Dump();
3683     if ($str =~ /^\$v/) {
3684         return '${my ' . $str . ' \$v}';
3685     } else {
3686         return $str;
3687     }
3688 }
3689
3690 sub const_sv {
3691     my $self = shift;
3692     my $op = shift;
3693     my $sv = $op->sv;
3694     # the constant could be in the pad (under useithreads)
3695     $sv = $self->padval($op->targ) unless $$sv;
3696     return $sv;
3697 }
3698
3699 sub pp_const {
3700     my $self = shift;
3701     my($op, $cx) = @_;
3702     if ($op->private & OPpCONST_ARYBASE) {
3703         return '$[';
3704     }
3705 #    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3706 #       return $self->const_sv($op)->PV;
3707 #    }
3708     my $sv = $self->const_sv($op);
3709     return $self->const($sv, $cx);
3710 }
3711
3712 sub dq {
3713     my $self = shift;
3714     my $op = shift;
3715     my $type = $op->name;
3716     if ($type eq "const") {
3717         return '$[' if $op->private & OPpCONST_ARYBASE;
3718         return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3719     } elsif ($type eq "concat") {
3720         my $first = $self->dq($op->first);
3721         my $last  = $self->dq($op->last);
3722
3723         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
3724         ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3725             $first =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
3726             || ($last =~ /^[:'{\[\w_]/ && #'
3727                 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3728
3729         return $first . $last;
3730     } elsif ($type eq "uc") {
3731         return '\U' . $self->dq($op->first->sibling) . '\E';
3732     } elsif ($type eq "lc") {
3733         return '\L' . $self->dq($op->first->sibling) . '\E';
3734     } elsif ($type eq "ucfirst") {
3735         return '\u' . $self->dq($op->first->sibling);
3736     } elsif ($type eq "lcfirst") {
3737         return '\l' . $self->dq($op->first->sibling);
3738     } elsif ($type eq "quotemeta") {
3739         return '\Q' . $self->dq($op->first->sibling) . '\E';
3740     } elsif ($type eq "join") {
3741         return $self->deparse($op->last, 26); # was join($", @ary)
3742     } else {
3743         return $self->deparse($op, 26);
3744     }
3745 }
3746
3747 sub pp_backtick {
3748     my $self = shift;
3749     my($op, $cx) = @_;
3750     # skip pushmark if it exists (readpipe() vs ``)
3751     my $child = $op->first->sibling->isa('B::NULL')
3752         ? $op->first->first : $op->first->sibling;
3753     return single_delim("qx", '`', $self->dq($child));
3754 }
3755
3756 sub dquote {
3757     my $self = shift;
3758     my($op, $cx) = @_;
3759     my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3760     return $self->deparse($kid, $cx) if $self->{'unquote'};
3761     $self->maybe_targmy($kid, $cx,
3762                         sub {single_delim("qq", '"', $self->dq($_[1]))});
3763 }
3764
3765 # OP_STRINGIFY is a listop, but it only ever has one arg
3766 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3767
3768 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3769 # note that tr(from)/to/ is OK, but not tr/from/(to)
3770 sub double_delim {
3771     my($from, $to) = @_;
3772     my($succeed, $delim);
3773     if ($from !~ m[/] and $to !~ m[/]) {
3774         return "/$from/$to/";
3775     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3776         if (($succeed, $to) = balanced_delim($to) and $succeed) {
3777             return "$from$to";
3778         } else {
3779             for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3780                 return "$from$delim$to$delim" if index($to, $delim) == -1;
3781             }
3782             $to =~ s[/][\\/]g;
3783             return "$from/$to/";
3784         }
3785     } else {
3786         for $delim ('/', '"', '#') { # note no '
3787             return "$delim$from$delim$to$delim"
3788                 if index($to . $from, $delim) == -1;
3789         }
3790         $from =~ s[/][\\/]g;
3791         $to =~ s[/][\\/]g;
3792         return "/$from/$to/";
3793     }
3794 }
3795
3796 # Only used by tr///, so backslashes hyphens
3797 sub pchr { # ASCII
3798     my($n) = @_;
3799     if ($n == ord '\\') {
3800         return '\\\\';
3801     } elsif ($n == ord "-") {
3802         return "\\-";
3803     } elsif ($n >= ord(' ') and $n <= ord('~')) {
3804         return chr($n);
3805     } elsif ($n == ord "\a") {
3806         return '\\a';
3807     } elsif ($n == ord "\b") {
3808         return '\\b';
3809     } elsif ($n == ord "\t") {
3810         return '\\t';
3811     } elsif ($n == ord "\n") {
3812         return '\\n';
3813     } elsif ($n == ord "\e") {
3814         return '\\e';
3815     } elsif ($n == ord "\f") {
3816         return '\\f';
3817     } elsif ($n == ord "\r") {
3818         return '\\r';
3819     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3820         return '\\c' . chr(ord("@") + $n);
3821     } else {
3822 #       return '\x' . sprintf("%02x", $n);
3823         return '\\' . sprintf("%03o", $n);
3824     }
3825 }
3826
3827 sub collapse {
3828     my(@chars) = @_;
3829     my($str, $c, $tr) = ("");
3830     for ($c = 0; $c < @chars; $c++) {
3831         $tr = $chars[$c];
3832         $str .= pchr($tr);
3833         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3834             $chars[$c + 2] == $tr + 2)
3835         {
3836             for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3837               {}
3838             $str .= "-";
3839             $str .= pchr($chars[$c]);
3840         }
3841     }
3842     return $str;
3843 }
3844
3845 sub tr_decode_byte {
3846     my($table, $flags) = @_;
3847     my(@table) = unpack("s*", $table);
3848     splice @table, 0x100, 1;   # Number of subsequent elements
3849     my($c, $tr, @from, @to, @delfrom, $delhyphen);
3850     if ($table[ord "-"] != -1 and
3851         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3852     {
3853         $tr = $table[ord "-"];
3854         $table[ord "-"] = -1;
3855         if ($tr >= 0) {
3856             @from = ord("-");
3857             @to = $tr;
3858         } else { # -2 ==> delete
3859             $delhyphen = 1;
3860         }
3861     }
3862     for ($c = 0; $c < @table; $c++) {
3863         $tr = $table[$c];
3864         if ($tr >= 0) {
3865             push @from, $c; push @to, $tr;
3866         } elsif ($tr == -2) {
3867             push @delfrom, $c;
3868         }
3869     }
3870     @from = (@from, @delfrom);
3871     if ($flags & OPpTRANS_COMPLEMENT) {
3872         my @newfrom = ();
3873         my %from;
3874         @from{@from} = (1) x @from;
3875         for ($c = 0; $c < 256; $c++) {
3876             push @newfrom, $c unless $from{$c};
3877         }
3878         @from = @newfrom;
3879     }
3880     unless ($flags & OPpTRANS_DELETE || !@to) {
3881         pop @to while $#to and $to[$#to] == $to[$#to -1];
3882     }
3883     my($from, $to);
3884     $from = collapse(@from);
3885     $to = collapse(@to);
3886     $from .= "-" if $delhyphen;
3887     return ($from, $to);
3888 }
3889
3890 sub tr_chr {
3891     my $x = shift;
3892     if ($x == ord "-") {
3893         return "\\-";
3894     } elsif ($x == ord "\\") {
3895         return "\\\\";
3896     } else {
3897         return chr $x;
3898     }
3899 }
3900
3901 # XXX This doesn't yet handle all cases correctly either
3902
3903 sub tr_decode_utf8 {
3904     my($swash_hv, $flags) = @_;
3905     my %swash = $swash_hv->ARRAY;
3906     my $final = undef;
3907     $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3908     my $none = $swash{"NONE"}->IV;
3909     my $extra = $none + 1;
3910     my(@from, @delfrom, @to);
3911     my $line;
3912     foreach $line (split /\n/, $swash{'LIST'}->PV) {
3913         my($min, $max, $result) = split(/\t/, $line);
3914         $min = hex $min;
3915         if (length $max) {
3916             $max = hex $max;
3917         } else {
3918             $max = $min;
3919         }
3920         $result = hex $result;
3921         if ($result == $extra) {
3922             push @delfrom, [$min, $max];
3923         } else {
3924             push @from, [$min, $max];
3925             push @to, [$result, $result + $max - $min];
3926         }
3927     }
3928     for my $i (0 .. $#from) {
3929         if ($from[$i][0] == ord '-') {
3930             unshift @from, splice(@from, $i, 1);
3931             unshift @to, splice(@to, $i, 1);
3932             last;
3933         } elsif ($from[$i][1] == ord '-') {
3934             $from[$i][1]--;
3935             $to[$i][1]--;
3936             unshift @from, ord '-';
3937             unshift @to, ord '-';
3938             last;
3939         }
3940     }
3941     for my $i (0 .. $#delfrom) {
3942         if ($delfrom[$i][0] == ord '-') {
3943             push @delfrom, splice(@delfrom, $i, 1);
3944             last;
3945         } elsif ($delfrom[$i][1] == ord '-') {
3946             $delfrom[$i][1]--;
3947             push @delfrom, ord '-';
3948             last;
3949         }
3950     }
3951     if (defined $final and $to[$#to][1] != $final) {
3952         push @to, [$final, $final];
3953     }
3954     push @from, @delfrom;
3955     if ($flags & OPpTRANS_COMPLEMENT) {
3956         my @newfrom;
3957         my $next = 0;
3958         for my $i (0 .. $#from) {
3959             push @newfrom, [$next, $from[$i][0] - 1];
3960             $next = $from[$i][1] + 1;
3961         }
3962         @from = ();
3963         for my $range (@newfrom) {
3964             if ($range->[0] <= $range->[1]) {
3965                 push @from, $range;
3966             }
3967         }
3968     }
3969     my($from, $to, $diff);
3970     for my $chunk (@from) {
3971         $diff = $chunk->[1] - $chunk->[0];
3972         if ($diff > 1) {
3973             $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3974         } elsif ($diff == 1) {
3975             $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3976         } else {
3977             $from .= tr_chr($chunk->[0]);
3978         }
3979     }
3980     for my $chunk (@to) {
3981         $diff = $chunk->[1] - $chunk->[0];
3982         if ($diff > 1) {
3983             $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3984         } elsif ($diff == 1) {
3985             $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3986         } else {
3987             $to .= tr_chr($chunk->[0]);
3988         }
3989     }
3990     #$final = sprintf("%04x", $final) if defined $final;
3991     #$none = sprintf("%04x", $none) if defined $none;
3992     #$extra = sprintf("%04x", $extra) if defined $extra;
3993     #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3994     #print STDERR $swash{'LIST'}->PV;
3995     return (escape_str($from), escape_str($to));
3996 }
3997
3998 sub pp_trans {
3999     my $self = shift;
4000     my($op, $cx) = @_;
4001     my($from, $to);
4002     if (class($op) eq "PVOP") {
4003         ($from, $to) = tr_decode_byte($op->pv, $op->private);
4004     } else { # class($op) eq "SVOP"
4005         ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
4006     }
4007     my $flags = "";
4008     $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
4009     $flags .= "d" if $op->private & OPpTRANS_DELETE;
4010     $to = "" if $from eq $to and $flags eq "";
4011     $flags .= "s" if $op->private & OPpTRANS_SQUASH;
4012     return "tr" . double_delim($from, $to) . $flags;
4013 }
4014
4015 # Like dq(), but different
4016 sub re_dq {
4017     my $self = shift;
4018     my ($op, $extended) = @_;
4019
4020     my $type = $op->name;
4021     if ($type eq "const") {
4022         return '$[' if $op->private & OPpCONST_ARYBASE;
4023         my $unbacked = re_unback($self->const_sv($op)->as_string);
4024         return re_uninterp_extended(escape_extended_re($unbacked))
4025             if $extended;
4026         return re_uninterp(escape_str($unbacked));
4027     } elsif ($type eq "concat") {
4028         my $first = $self->re_dq($op->first, $extended);
4029         my $last  = $self->re_dq($op->last,  $extended);
4030
4031         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
4032         ($last =~ /^[A-Z\\\^\[\]_?]/ &&
4033             $first =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
4034             || ($last =~ /^[{\[\w_]/ &&
4035                 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
4036
4037         return $first . $last;
4038     } elsif ($type eq "uc") {
4039         return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
4040     } elsif ($type eq "lc") {
4041         return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
4042     } elsif ($type eq "ucfirst") {
4043         return '\u' . $self->re_dq($op->first->sibling, $extended);
4044     } elsif ($type eq "lcfirst") {
4045         return '\l' . $self->re_dq($op->first->sibling, $extended);
4046     } elsif ($type eq "quotemeta") {
4047         return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
4048     } elsif ($type eq "join") {
4049         return $self->deparse($op->last, 26); # was join($", @ary)
4050     } else {
4051         return $self->deparse($op, 26);
4052     }
4053 }
4054
4055 sub pure_string {
4056     my ($self, $op) = @_;
4057     return 0 if null $op;
4058     my $type = $op->name;
4059
4060     if ($type eq 'const') {
4061         return 1;
4062     }
4063     elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
4064         return $self->pure_string($op->first->sibling);
4065     }
4066     elsif ($type eq 'join') {
4067         my $join_op = $op->first->sibling;  # Skip pushmark
4068         return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
4069
4070         my $gvop = $join_op->first;
4071         return 0 unless $gvop->name eq 'gvsv';
4072         return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
4073
4074         return 0 unless ${$join_op->sibling} eq ${$op->last};
4075         return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
4076     }
4077     elsif ($type eq 'concat') {
4078         return $self->pure_string($op->first)
4079             && $self->pure_string($op->last);
4080     }
4081     elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
4082         return 1;
4083     }
4084     elsif ($type eq "null" and $op->can('first') and not null $op->first and
4085            $op->first->name eq "null" and $op->first->can('first')
4086            and not null $op->first->first and
4087            $op->first->first->name eq "aelemfast") {
4088         return 1;
4089     }
4090     else {
4091         return 0;
4092     }
4093
4094     return 1;
4095 }
4096
4097 sub regcomp {
4098     my $self = shift;
4099     my($op, $cx, $extended) = @_;
4100     my $kid = $op->first;
4101     $kid = $kid->first if $kid->name eq "regcmaybe";
4102     $kid = $kid->first if $kid->name eq "regcreset";
4103     if ($kid->name eq "null" and !null($kid->first)
4104         and $kid->first->name eq 'pushmark')
4105     {
4106         my $str = '';
4107         $kid = $kid->first->sibling;
4108         while (!null($kid)) {
4109             $str .= $self->re_dq($kid, $extended);
4110             $kid = $kid->sibling;
4111         }
4112         return $str, 1;
4113     }
4114
4115     return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
4116     return ($self->deparse($kid, $cx), 0);
4117 }
4118
4119 sub pp_regcomp {
4120     my ($self, $op, $cx) = @_;
4121     return (($self->regcomp($op, $cx, 0))[0]);
4122 }
4123
4124 # osmic acid -- see osmium tetroxide
4125
4126 my %matchwords;
4127 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
4128     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
4129     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
4130
4131 sub matchop {
4132     my $self = shift;
4133     my($op, $cx, $name, $delim) = @_;
4134     my $kid = $op->first;
4135     my ($binop, $var, $re) = ("", "", "");
4136     if ($op->flags & OPf_STACKED) {
4137         $binop = 1;
4138         $var = $self->deparse($kid, 20);
4139         $kid = $kid->sibling;
4140     }
4141     my $quote = 1;
4142     my $extended = ($op->pmflags & PMf_EXTENDED);
4143     if (null $kid) {
4144         my $unbacked = re_unback($op->precomp);
4145         if ($extended) {
4146             $re = re_uninterp_extended(escape_extended_re($unbacked));
4147         } else {
4148             $re = re_uninterp(escape_str(re_unback($op->precomp)));
4149         }
4150     } elsif ($kid->name ne 'regcomp') {
4151         carp("found ".$kid->name." where regcomp expected");
4152     } else {
4153         ($re, $quote) = $self->regcomp($kid, 21, $extended);
4154     }
4155     my $flags = "";
4156     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
4157     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
4158     $flags .= "i" if $op->pmflags & PMf_FOLD;
4159     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
4160     $flags .= "o" if $op->pmflags & PMf_KEEP;
4161     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
4162     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
4163     $flags = $matchwords{$flags} if $matchwords{$flags};
4164     if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
4165         $re =~ s/\?/\\?/g;
4166         $re = "?$re?";
4167     } elsif ($quote) {
4168         $re = single_delim($name, $delim, $re);
4169     }
4170     $re = $re . $flags if $quote;
4171     if ($binop) {
4172         return $self->maybe_parens("$var =~ $re", $cx, 20);
4173     } else {
4174         return $re;
4175     }
4176 }
4177
4178 sub pp_match { matchop(@_, "m", "/") }
4179 sub pp_pushre { matchop(@_, "m", "/") }
4180 sub pp_qr { matchop(@_, "qr", "") }
4181
4182 sub pp_split {
4183     my $self = shift;
4184     my($op, $cx) = @_;
4185     my($kid, @exprs, $ary, $expr);
4186     $kid = $op->first;
4187
4188     # For our kid (an OP_PUSHRE), pmreplroot is never actually the
4189     # root of a replacement; it's either empty, or abused to point to
4190     # the GV for an array we split into (an optimization to save
4191     # assignment overhead). Depending on whether we're using ithreads,
4192     # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
4193     # figures out for us which it is.
4194     my $replroot = $kid->pmreplroot;
4195     my $gv = 0;
4196     if (ref($replroot) eq "B::GV") {
4197         $gv = $replroot;
4198     } elsif (!ref($replroot) and $replroot > 0) {
4199         $gv = $self->padval($replroot);
4200     }
4201     $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv;
4202
4203     for (; !null($kid); $kid = $kid->sibling) {
4204         push @exprs, $self->deparse($kid, 6);
4205     }
4206
4207     # handle special case of split(), and split(' ') that compiles to /\s+/
4208     $kid = $op->first;
4209     if ( $kid->flags & OPf_SPECIAL
4210          and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
4211               : $kid->reflags & RXf_SKIPWHITE() ) ) {
4212         $exprs[0] = "' '";
4213     }
4214
4215     $expr = "split(" . join(", ", @exprs) . ")";
4216     if ($ary) {
4217         return $self->maybe_parens("$ary = $expr", $cx, 7);
4218     } else {
4219         return $expr;
4220     }
4221 }
4222
4223 # oxime -- any of various compounds obtained chiefly by the action of
4224 # hydroxylamine on aldehydes and ketones and characterized by the
4225 # bivalent grouping C=NOH [Webster's Tenth]
4226
4227 my %substwords;
4228 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
4229     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
4230     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
4231     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
4232
4233 sub pp_subst {
4234     my $self = shift;
4235     my($op, $cx) = @_;
4236     my $kid = $op->first;
4237     my($binop, $var, $re, $repl) = ("", "", "", "");
4238     if ($op->flags & OPf_STACKED) {
4239         $binop = 1;
4240         $var = $self->deparse($kid, 20);
4241         $kid = $kid->sibling;
4242     }
4243     my $flags = "";
4244     if (null($op->pmreplroot)) {
4245         $repl = $self->dq($kid);
4246         $kid = $kid->sibling;
4247     } else {
4248         $repl = $op->pmreplroot->first; # skip substcont
4249         while ($repl->name eq "entereval") {
4250             $repl = $repl->first;
4251             $flags .= "e";
4252         }
4253         if ($op->pmflags & PMf_EVAL) {
4254             $repl = $self->deparse($repl->first, 0);
4255         } else {
4256             $repl = $self->dq($repl);
4257         }
4258     }
4259     my $extended = ($op->pmflags & PMf_EXTENDED);
4260     if (null $kid) {
4261         my $unbacked = re_unback($op->precomp);
4262         if ($extended) {
4263             $re = re_uninterp_extended(escape_extended_re($unbacked));
4264         }
4265         else {
4266             $re = re_uninterp(escape_str($unbacked));
4267         }
4268     } else {
4269         ($re) = $self->regcomp($kid, 1, $extended);
4270     }
4271     $flags .= "e" if $op->pmflags & PMf_EVAL;
4272     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
4273     $flags .= "i" if $op->pmflags & PMf_FOLD;
4274     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
4275     $flags .= "o" if $op->pmflags & PMf_KEEP;
4276     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
4277     $flags .= "x" if $extended;
4278     $flags = $substwords{$flags} if $substwords{$flags};
4279     if ($binop) {
4280         return $self->maybe_parens("$var =~ s"
4281                                    . double_delim($re, $repl) . $flags,
4282                                    $cx, 20);
4283     } else {
4284         return "s". double_delim($re, $repl) . $flags;
4285     }
4286 }
4287
4288 1;
4289 __END__
4290
4291 =head1 NAME
4292
4293 B::Deparse - Perl compiler backend to produce perl code
4294
4295 =head1 SYNOPSIS
4296
4297 B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
4298         [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
4299
4300 =head1 DESCRIPTION
4301
4302 B::Deparse is a backend module for the Perl compiler that generates
4303 perl source code, based on the internal compiled structure that perl
4304 itself creates after parsing a program. The output of B::Deparse won't
4305 be exactly the same as the original source, since perl doesn't keep
4306 track of comments or whitespace, and there isn't a one-to-one
4307 correspondence between perl's syntactical constructions and their
4308 compiled form, but it will often be close. When you use the B<-p>
4309 option, the output also includes parentheses even when they are not
4310 required by precedence, which can make it easy to see if perl is
4311 parsing your expressions the way you intended.
4312
4313 While B::Deparse goes to some lengths to try to figure out what your
4314 original program was doing, some parts of the language can still trip
4315 it up; it still fails even on some parts of Perl's own test suite. If
4316 you encounter a failure other than the most common ones described in
4317 the BUGS section below, you can help contribute to B::Deparse's
4318 ongoing development by submitting a bug report with a small
4319 example.
4320
4321 =head1 OPTIONS
4322
4323 As with all compiler backend options, these must follow directly after
4324 the '-MO=Deparse', separated by a comma but not any white space.
4325
4326 =over 4
4327
4328 =item B<-d>
4329
4330 Output data values (when they appear as constants) using Data::Dumper.
4331 Without this option, B::Deparse will use some simple routines of its
4332 own for the same purpose. Currently, Data::Dumper is better for some
4333 kinds of data (such as complex structures with sharing and
4334 self-reference) while the built-in routines are better for others
4335 (such as odd floating-point values).
4336
4337 =item B<-f>I<FILE>
4338
4339 Normally, B::Deparse deparses the main code of a program, and all the subs
4340 defined in the same file. To include subs defined in other files, pass the
4341 B<-f> option with the filename. You can pass the B<-f> option several times, to
4342 include more than one secondary file.  (Most of the time you don't want to
4343 use it at all.)  You can also use this option to include subs which are
4344 defined in the scope of a B<#line> directive with two parameters.
4345
4346 =item B<-l>
4347
4348 Add '#line' declarations to the output based on the line and file
4349 locations of the original code.
4350
4351 =item B<-p>
4352
4353 Print extra parentheses. Without this option, B::Deparse includes
4354 parentheses in its output only when they are needed, based on the
4355 structure of your program. With B<-p>, it uses parentheses (almost)
4356 whenever they would be legal. This can be useful if you are used to
4357 LISP, or if you want to see how perl parses your input. If you say
4358
4359     if ($var & 0x7f == 65) {print "Gimme an A!"}
4360     print ($which ? $a : $b), "\n";
4361     $name = $ENV{USER} or "Bob";
4362
4363 C<B::Deparse,-p> will print
4364
4365     if (($var & 0)) {
4366         print('Gimme an A!')
4367     };
4368     (print(($which ? $a : $b)), '???');
4369     (($name = $ENV{'USER'}) or '???')
4370
4371 which probably isn't what you intended (the C<'???'> is a sign that
4372 perl optimized away a constant value).
4373
4374 =item B<-P>
4375
4376 Disable prototype checking. With this option, all function calls are
4377 deparsed as if no prototype was defined for them. In other words,
4378
4379     perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
4380
4381 will print
4382
4383     sub foo (\@) {
4384         1;
4385     }
4386     &foo(\@x);
4387
4388 making clear how the parameters are actually passed to C<foo>.
4389
4390 =item B<-q>
4391
4392 Expand double-quoted strings into the corresponding combinations of
4393 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
4394 instance, print
4395
4396     print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
4397
4398 as
4399
4400     print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
4401           . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
4402
4403 Note that the expanded form represents the way perl handles such
4404 constructions internally -- this option actually turns off the reverse
4405 translation that B::Deparse usually does. On the other hand, note that
4406 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
4407 of $y into a string before doing the assignment.
4408
4409 =item B<-s>I<LETTERS>
4410
4411 Tweak the style of B::Deparse's output. The letters should follow
4412 directly after the 's', with no space or punctuation. The following
4413 options are available:
4414
4415 =over 4
4416
4417 =item B<C>
4418
4419 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
4420
4421     if (...) {
4422          ...
4423     } else {
4424          ...
4425     }
4426
4427 instead of
4428
4429     if (...) {
4430          ...
4431     }
4432     else {
4433          ...
4434     }
4435
4436 The default is not to cuddle.
4437
4438 =item B<i>I<NUMBER>
4439
4440 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
4441
4442 =item B<T>
4443
4444 Use tabs for each 8 columns of indent. The default is to use only spaces.
4445 For instance, if the style options are B<-si4T>, a line that's indented
4446 3 times will be preceded by one tab and four spaces; if the options were
4447 B<-si8T>, the same line would be preceded by three tabs.
4448
4449 =item B<v>I<STRING>B<.>
4450
4451 Print I<STRING> for the value of a constant that can't be determined
4452 because it was optimized away (mnemonic: this happens when a constant
4453 is used in B<v>oid context). The end of the string is marked by a period.
4454 The string should be a valid perl expression, generally a constant.
4455 Note that unless it's a number, it probably needs to be quoted, and on
4456 a command line quotes need to be protected from the shell. Some
4457 conventional values include 0, 1, 42, '', 'foo', and
4458 'Useless use of constant omitted' (which may need to be
4459 B<-sv"'Useless use of constant omitted'.">
4460 or something similar depending on your shell). The default is '???'.
4461 If you're using B::Deparse on a module or other file that's require'd,
4462 you shouldn't use a value that evaluates to false, since the customary
4463 true constant at the end of a module will be in void context when the
4464 file is compiled as a main program.
4465
4466 =back
4467
4468 =item B<-x>I<LEVEL>
4469
4470 Expand conventional syntax constructions into equivalent ones that expose
4471 their internal operation. I<LEVEL> should be a digit, with higher values
4472 meaning more expansion. As with B<-q>, this actually involves turning off
4473 special cases in B::Deparse's normal operations.
4474
4475 If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
4476 while loops with continue blocks; for instance
4477
4478     for ($i = 0; $i < 10; ++$i) {
4479         print $i;
4480     }
4481
4482 turns into
4483
4484     $i = 0;
4485     while ($i < 10) {
4486         print $i;
4487     } continue {
4488         ++$i
4489     }
4490
4491 Note that in a few cases this translation can't be perfectly carried back
4492 into the source code -- if the loop's initializer declares a my variable,
4493 for instance, it won't have the correct scope outside of the loop.
4494
4495 If I<LEVEL> is at least 5, C<use> declarations will be translated into
4496 C<BEGIN> blocks containing calls to C<require> and C<import>; for
4497 instance,
4498
4499     use strict 'refs';
4500
4501 turns into
4502
4503     sub BEGIN {
4504         require strict;
4505         do {
4506             'strict'->import('refs')
4507         };
4508     }
4509
4510 If I<LEVEL> is at least 7, C<if> statements will be translated into
4511 equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
4512
4513     print 'hi' if $nice;
4514     if ($nice) {
4515         print 'hi';
4516     }
4517     if ($nice) {
4518         print 'hi';
4519     } else {
4520         print 'bye';
4521     }
4522
4523 turns into
4524
4525     $nice and print 'hi';
4526     $nice and do { print 'hi' };
4527     $nice ? do { print 'hi' } : do { print 'bye' };
4528
4529 Long sequences of elsifs will turn into nested ternary operators, which
4530 B::Deparse doesn't know how to indent nicely.
4531
4532 =back
4533
4534 =head1 USING B::Deparse AS A MODULE
4535
4536 =head2 Synopsis
4537
4538     use B::Deparse;
4539     $deparse = B::Deparse->new("-p", "-sC");
4540     $body = $deparse->coderef2text(\&func);
4541     eval "sub func $body"; # the inverse operation
4542
4543 =head2 Description
4544
4545 B::Deparse can also be used on a sub-by-sub basis from other perl
4546 programs.
4547
4548 =head2 new
4549
4550     $deparse = B::Deparse->new(OPTIONS)
4551
4552 Create an object to store the state of a deparsing operation and any
4553 options. The options are the same as those that can be given on the
4554 command line (see L</OPTIONS>); options that are separated by commas
4555 after B<-MO=Deparse> should be given as separate strings. Some
4556 options, like B<-u>, don't make sense for a single subroutine, so
4557 don't pass them.
4558
4559 =head2 ambient_pragmas
4560
4561     $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
4562
4563 The compilation of a subroutine can be affected by a few compiler
4564 directives, B<pragmas>. These are:
4565
4566 =over 4
4567
4568 =item *
4569
4570 use strict;
4571
4572 =item *
4573
4574 use warnings;
4575
4576 =item *
4577
4578 Assigning to the special variable $[
4579
4580 =item *
4581
4582 use integer;
4583
4584 =item *
4585
4586 use bytes;
4587
4588 =item *
4589
4590 use utf8;
4591
4592 =item *
4593
4594 use re;
4595
4596 =back
4597
4598 Ordinarily, if you use B::Deparse on a subroutine which has
4599 been compiled in the presence of one or more of these pragmas,
4600 the output will include statements to turn on the appropriate
4601 directives. So if you then compile the code returned by coderef2text,
4602 it will behave the same way as the subroutine which you deparsed.
4603
4604 However, you may know that you intend to use the results in a
4605 particular context, where some pragmas are already in scope. In
4606 this case, you use the B<ambient_pragmas> method to describe the
4607 assumptions you wish to make.
4608
4609 Not all of the options currently have any useful effect. See
4610 L</BUGS> for more details.
4611
4612 The parameters it accepts are:
4613
4614 =over 4
4615
4616 =item strict
4617
4618 Takes a string, possibly containing several values separated
4619 by whitespace. The special values "all" and "none" mean what you'd
4620 expect.
4621
4622     $deparse->ambient_pragmas(strict => 'subs refs');
4623
4624 =item $[
4625
4626 Takes a number, the value of the array base $[.
4627
4628 =item bytes
4629
4630 =item utf8
4631
4632 =item integer
4633
4634 If the value is true, then the appropriate pragma is assumed to
4635 be in the ambient scope, otherwise not.
4636
4637 =item re
4638
4639 Takes a string, possibly containing a whitespace-separated list of
4640 values. The values "all" and "none" are special. It's also permissible
4641 to pass an array reference here.
4642
4643     $deparser->ambient_pragmas(re => 'eval');
4644
4645
4646 =item warnings
4647
4648 Takes a string, possibly containing a whitespace-separated list of
4649 values. The values "all" and "none" are special, again. It's also
4650 permissible to pass an array reference here.
4651
4652     $deparser->ambient_pragmas(warnings => [qw[void io]]);
4653
4654 If one of the values is the string "FATAL", then all the warnings
4655 in that list will be considered fatal, just as with the B<warnings>
4656 pragma itself. Should you need to specify that some warnings are
4657 fatal, and others are merely enabled, you can pass the B<warnings>
4658 parameter twice:
4659
4660     $deparser->ambient_pragmas(
4661         warnings => 'all',
4662         warnings => [FATAL => qw/void io/],
4663     );
4664
4665 See L<perllexwarn> for more information about lexical warnings.
4666
4667 =item hint_bits
4668
4669 =item warning_bits
4670
4671 These two parameters are used to specify the ambient pragmas in
4672 the format used by the special variables $^H and ${^WARNING_BITS}.
4673
4674 They exist principally so that you can write code like:
4675
4676     { my ($hint_bits, $warning_bits);
4677     BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
4678     $deparser->ambient_pragmas (
4679         hint_bits    => $hint_bits,
4680         warning_bits => $warning_bits,
4681         '$['         => 0 + $[
4682     ); }
4683
4684 which specifies that the ambient pragmas are exactly those which
4685 are in scope at the point of calling.
4686
4687 =back
4688
4689 =head2 coderef2text
4690
4691     $body = $deparse->coderef2text(\&func)
4692     $body = $deparse->coderef2text(sub ($$) { ... })
4693
4694 Return source code for the body of a subroutine (a block, optionally
4695 preceded by a prototype in parens), given a reference to the
4696 sub. Because a subroutine can have no names, or more than one name,
4697 this method doesn't return a complete subroutine definition -- if you
4698 want to eval the result, you should prepend "sub subname ", or "sub "
4699 for an anonymous function constructor. Unless the sub was defined in
4700 the main:: package, the code will include a package declaration.
4701
4702 =head1 BUGS
4703
4704 =over 4
4705
4706 =item *
4707
4708 The only pragmas to be completely supported are: C<use warnings>,
4709 C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
4710 behaves like a pragma, is also supported.)
4711
4712 Excepting those listed above, we're currently unable to guarantee that
4713 B::Deparse will produce a pragma at the correct point in the program.
4714 (Specifically, pragmas at the beginning of a block often appear right
4715 before the start of the block instead.)
4716 Since the effects of pragmas are often lexically scoped, this can mean
4717 that the pragma holds sway over a different portion of the program
4718 than in the input file.
4719
4720 =item *
4721
4722 In fact, the above is a specific instance of a more general problem:
4723 we can't guarantee to produce BEGIN blocks or C<use> declarations in
4724 exactly the right place. So if you use a module which affects compilation
4725 (such as by over-riding keywords, overloading constants or whatever)
4726 then the output code might not work as intended.
4727
4728 This is the most serious outstanding problem, and will require some help
4729 from the Perl core to fix.
4730
4731 =item *
4732
4733 If a keyword is over-ridden, and your program explicitly calls
4734 the built-in version by using CORE::keyword, the output of B::Deparse
4735 will not reflect this. If you run the resulting code, it will call
4736 the over-ridden version rather than the built-in one. (Maybe there
4737 should be an option to B<always> print keyword calls as C<CORE::name>.)
4738
4739 =item *
4740
4741 Some constants don't print correctly either with or without B<-d>.
4742 For instance, neither B::Deparse nor Data::Dumper know how to print
4743 dual-valued scalars correctly, as in:
4744
4745     use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
4746
4747 =item *
4748
4749 An input file that uses source filtering probably won't be deparsed into
4750 runnable code, because it will still include the B<use> declaration
4751 for the source filtering module, even though the code that is
4752 produced is already ordinary Perl which shouldn't be filtered again.
4753
4754 =item *
4755
4756 Optimised away statements are rendered as '???'. This includes statements that
4757 have a compile-time side-effect, such as the obscure
4758
4759     my $x if 0;
4760
4761 which is not, consequently, deparsed correctly.
4762
4763 =item *
4764
4765 Lexical (my) variables declared in scopes external to a subroutine
4766 appear in code2ref output text as package variables. This is a tricky
4767 problem, as perl has no native facility for refering to a lexical variable
4768 defined within a different scope, although L<PadWalker> is a good start.
4769
4770 =item *
4771
4772 There are probably many more bugs on non-ASCII platforms (EBCDIC).
4773
4774 =back
4775
4776 =head1 AUTHOR
4777
4778 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version
4779 by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from
4780 Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
4781 Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael
4782 Garcia-Suarez.
4783
4784 =cut