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