ext/B/B/Deparse.pm

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