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