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.12";
  24 use strict;
  25 use vars qw/$AUTOLOAD/;
  26 use warnings ();
  27
  28 BEGIN {
  29     # List version-specific constants here.
  30     # Easiest way to keep this code portable between version looks to
  31     # be to fake up a dummy constant that will never actually be true.
  32     foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
  33                 OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE
  34                 RXf_PMf_CHARSET RXf_PMf_KEEPCOPY
  35                 CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
  36                 PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES)) {
  37         eval { import B $_ };
  38         no strict 'refs';
  39         *{$_} = sub () {0} unless *{$_}{CODE};
  40     }
  41 }
  42
  43 # Changes between 0.50 and 0.51:
  44 # - fixed nulled leave with live enter in sort { }
  45 # - fixed reference constants (\"str")
  46 # - handle empty programs gracefully
  47 # - handle infinite loops (for (;;) {}, while (1) {})
  48 # - differentiate between 'for my $x ...' and 'my $x; for $x ...'
  49 # - various minor cleanups
  50 # - moved globals into an object
  51 # - added '-u', like B::C
  52 # - package declarations using cop_stash
  53 # - subs, formats and code sorted by cop_seq
  54 # Changes between 0.51 and 0.52:
  55 # - added pp_threadsv (special variables under USE_5005THREADS)
  56 # - added documentation
  57 # Changes between 0.52 and 0.53:
  58 # - many changes adding precedence contexts and associativity
  59 # - added '-p' and '-s' output style options
  60 # - various other minor fixes
  61 # Changes between 0.53 and 0.54:
  62 # - added support for new 'for (1..100)' optimization,
  63 #   thanks to Gisle Aas
  64 # Changes between 0.54 and 0.55:
  65 # - added support for new qr// construct
  66 # - added support for new pp_regcreset OP
  67 # Changes between 0.55 and 0.56:
  68 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
  69 # - fixed $# on non-lexicals broken in last big rewrite
  70 # - added temporary fix for change in opcode of OP_STRINGIFY
  71 # - fixed problem in 0.54's for() patch in 'for (@ary)'
  72 # - fixed precedence in conditional of ?:
  73 # - tweaked list paren elimination in 'my($x) = @_'
  74 # - made continue-block detection trickier wrt. null ops
  75 # - fixed various prototype problems in pp_entersub
  76 # - added support for sub prototypes that never get GVs
  77 # - added unquoting for special filehandle first arg in truncate
  78 # - print doubled rv2gv (a bug) as '*{*GV}' instead of illegal '**GV'
  79 # - added semicolons at the ends of blocks
  80 # - added -l '#line' declaration option -- fixes cmd/subval.t 27,28
  81 # Changes between 0.56 and 0.561:
  82 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
  83 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
  84 # Changes between 0.561 and 0.57:
  85 # - stylistic changes to symbolic constant stuff
  86 # - handled scope in s///e replacement code
  87 # - added unquote option for expanding "" into concats, etc.
  88 # - split method and proto parts of pp_entersub into separate functions
  89 # - various minor cleanups
  90 # Changes after 0.57:
  91 # - added parens in \&foo (patch by Albert Dvornik)
  92 # Changes between 0.57 and 0.58:
  93 # - fixed '0' statements that weren't being printed
  94 # - added methods for use from other programs
  95 #   (based on patches from James Duncan and Hugo van der Sanden)
  96 # - added -si and -sT to control indenting (also based on a patch from Hugo)
  97 # - added -sv to print something else instead of '???'
  98 # - preliminary version of utf8 tr/// handling
  99 # Changes after 0.58:
 100 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
 101 # - added support for Hugo's new OP_SETSTATE (like nextstate)
 102 # Changes between 0.58 and 0.59
 103 # - added support for Chip's OP_METHOD_NAMED
 104 # - added support for Ilya's OPpTARGET_MY optimization
 105 # - elided arrows before '()' subscripts when possible
 106 # Changes between 0.59 and 0.60
 107 # - support for method attributes was added
 108 # - some warnings fixed
 109 # - separate recognition of constant subs
 110 # - rewrote continue block handling, now recognizing for loops
 111 # - added more control of expanding control structures
 112 # Changes between 0.60 and 0.61 (mostly by Robin Houston)
 113 # - many bug-fixes
 114 # - support for pragmas and 'use'
 115 # - support for the little-used $[ variable
 116 # - support for __DATA__ sections
 117 # - UTF8 support
 118 # - BEGIN, CHECK, INIT and END blocks
 119 # - scoping of subroutine declarations fixed
 120 # - compile-time output from the input program can be suppressed, so that the
 121 #   output is just the deparsed code. (a change to O.pm in fact)
 122 # - our() declarations
 123 # - *all* the known bugs are now listed in the BUGS section
 124 # - comprehensive test mechanism (TEST -deparse)
 125 # Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
 126 # - bug-fixes
 127 # - new switch -P
 128 # - support for command-line switches (-l, -0, etc.)
 129 # Changes between 0.63 and 0.64
 130 # - support for //, CHECK blocks, and assertions
 131 # - improved handling of foreach loops and lexicals
 132 # - option to use Data::Dumper for constants
 133 # - more bug fixes
 134 # - discovered lots more bugs not yet fixed
 135 #
 136 # ...
 137 #
 138 # Changes between 0.72 and 0.73
 139 # - support new switch constructs
 140
 141 # Todo:
 142 #  (See also BUGS section at the end of this file)
 143 #
 144 # - finish tr/// changes
 145 # - add option for even more parens (generalize \&foo change)
 146 # - left/right context
 147 # - copy comments (look at real text with $^P?)
 148 # - avoid semis in one-statement blocks
 149 # - associativity of &&=, ||=, ?:
 150 # - ',' => '=>' (auto-unquote?)
 151 # - break long lines ("\r" as discretionary break?)
 152 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
 153 # - more style options: brace style, hex vs. octal, quotes, ...
 154 # - print big ints as hex/octal instead of decimal (heuristic?)
 155 # - handle 'my $x if 0'?
 156 # - version using op_next instead of op_first/sibling?
 157 # - avoid string copies (pass arrays, one big join?)
 158 # - here-docs?
 159
 160 # Current test.deparse failures
 161 # comp/hints 6 - location of BEGIN blocks wrt. block openings
 162 # run/switchI 1 - missing -I switches entirely
 163 #    perl -Ifoo -e 'print @INC'
 164 # op/caller 2 - warning mask propagates backwards before warnings::register
 165 #    'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
 166 # op/getpid 2 - can't assign to shared my() declaration (threads only)
 167 #    'my $x : shared = 5'
 168 # op/override 7 - parens on overridden require change v-string interpretation
 169 #    'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
 170 #    c.f. 'BEGIN { *f = sub {0} }; f 2'
 171 # op/pat 774 - losing Unicode-ness of Latin1-only strings
 172 #    'use charnames ":short"; $x="\N{latin:a with acute}"'
 173 # op/recurse 12 - missing parens on recursive call makes it look like method
 174 #    'sub f { f($x) }'
 175 # op/subst 90 - inconsistent handling of utf8 under "use utf8"
 176 # op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
 177 # op/tiehandle compile - "use strict" deparsed in the wrong place
 178 # uni/tr_ several
 179 # ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
 180 # ext/Data/Dumper/t/dumper compile
 181 # ext/DB_file/several
 182 # ext/Encode/several
 183 # ext/Ernno/Errno warnings
 184 # ext/IO/lib/IO/t/io_sel 23
 185 # ext/PerlIO/t/encoding compile
 186 # ext/POSIX/t/posix 6
 187 # ext/Socket/Socket 8
 188 # ext/Storable/t/croak compile
 189 # lib/Attribute/Handlers/t/multi compile
 190 # lib/bignum/ several
 191 # lib/charnames 35
 192 # lib/constant 32
 193 # lib/English 40
 194 # lib/ExtUtils/t/bytes 4
 195 # lib/File/DosGlob compile
 196 # lib/Filter/Simple/t/data 1
 197 # lib/Math/BigInt/t/constant 1
 198 # lib/Net/t/config Deparse-warning
 199 # lib/overload compile
 200 # lib/Switch/ several
 201 # lib/Symbol 4
 202 # lib/Test/Simple several
 203 # lib/Term/Complete
 204 # lib/Tie/File/t/29_downcopy 5
 205 # lib/vars 22
 206
 207 # Object fields (were globals):
 208 #
 209 # avoid_local:
 210 # (local($a), local($b)) and local($a, $b) have the same internal
 211 # representation but the short form looks better. We notice we can
 212 # use a large-scale local when checking the list, but need to prevent
 213 # individual locals too. This hash holds the addresses of OPs that
 214 # have already had their local-ness accounted for. The same thing
 215 # is done with my().
 216 #
 217 # curcv:
 218 # CV for current sub (or main program) being deparsed
 219 #
 220 # curcvlex:
 221 # Cached hash of lexical variables for curcv: keys are
 222 # names prefixed with "m" or "o" (representing my/our), and
 223 # each value is an array of pairs, indicating the cop_seq of scopes
 224 # in which a var of that name is valid.
 225 #
 226 # curcop:
 227 # COP for statement being deparsed
 228 #
 229 # curstash:
 230 # name of the current package for deparsed code
 231 #
 232 # subs_todo:
 233 # array of [cop_seq, CV, is_format?] for subs and formats we still
 234 # want to deparse
 235 #
 236 # protos_todo:
 237 # as above, but [name, prototype] for subs that never got a GV
 238 #
 239 # subs_done, forms_done:
 240 # keys are addresses of GVs for subs and formats we've already
 241 # deparsed (or at least put into subs_todo)
 242 #
 243 # subs_declared
 244 # keys are names of subs for which we've printed declarations.
 245 # That means we can omit parentheses from the arguments. It also means we
 246 # need to put CORE:: on core functions of the same name.
 247 #
 248 # subs_deparsed
 249 # Keeps track of fully qualified names of all deparsed subs.
 250 #
 251 # parens: -p
 252 # linenums: -l
 253 # unquote: -q
 254 # cuddle: ' ' or '\n', depending on -sC
 255 # indent_size: -si
 256 # use_tabs: -sT
 257 # ex_const: -sv
 258
 259 # A little explanation of how precedence contexts and associativity
 260 # work:
 261 #
 262 # deparse() calls each per-op subroutine with an argument $cx (short
 263 # for context, but not the same as the cx* in the perl core), which is
 264 # a number describing the op's parents in terms of precedence, whether
 265 # they're inside an expression or at statement level, etc.  (see
 266 # chart below). When ops with children call deparse on them, they pass
 267 # along their precedence. Fractional values are used to implement
 268 # associativity ('($x + $y) + $z' => '$x + $y + $y') and related
 269 # parentheses hacks. The major disadvantage of this scheme is that
 270 # it doesn't know about right sides and left sides, so say if you
 271 # assign a listop to a variable, it can't tell it's allowed to leave
 272 # the parens off the listop.
 273
 274 # Precedences:
 275 # 26             [TODO] inside interpolation context ("")
 276 # 25 left        terms and list operators (leftward)
 277 # 24 left        ->
 278 # 23 nonassoc    ++ --
 279 # 22 right       **
 280 # 21 right       ! ~ \ and unary + and -
 281 # 20 left        =~ !~
 282 # 19 left        * / % x
 283 # 18 left        + - .
 284 # 17 left        << >>
 285 # 16 nonassoc    named unary operators
 286 # 15 nonassoc    < > <= >= lt gt le ge
 287 # 14 nonassoc    == != <=> eq ne cmp
 288 # 13 left        &
 289 # 12 left        | ^
 290 # 11 left        &&
 291 # 10 left        ||
 292 #  9 nonassoc    ..  ...
 293 #  8 right       ?:
 294 #  7 right       = += -= *= etc.
 295 #  6 left        , =>
 296 #  5 nonassoc    list operators (rightward)
 297 #  4 right       not
 298 #  3 left        and
 299 #  2 left        or xor
 300 #  1             statement modifiers
 301 #  0.5           statements, but still print scopes as do { ... }
 302 #  0             statement level
 303
 304 # Nonprinting characters with special meaning:
 305 # \cS - steal parens (see maybe_parens_unop)
 306 # \n - newline and indent
 307 # \t - increase indent
 308 # \b - decrease indent ('outdent')
 309 # \f - flush left (no indent)
 310 # \cK - kill following semicolon, if any
 311
 312 sub null {
 313     my $op = shift;
 314     return class($op) eq "NULL";
 315 }
 316
 317 sub todo {
 318     my $self = shift;
 319     my($cv, $is_form) = @_;
 320     return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
 321     my $seq;
 322     if ($cv->OUTSIDE_SEQ) {
 323         $seq = $cv->OUTSIDE_SEQ;
 324     } elsif (!null($cv->START) and is_state($cv->START)) {
 325         $seq = $cv->START->cop_seq;
 326     } else {
 327         $seq = 0;
 328     }
 329     push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
 330     unless ($is_form || class($cv->STASH) eq 'SPECIAL') {
 331         $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1;
 332     }
 333 }
 334
 335 sub next_todo {
 336     my $self = shift;
 337     my $ent = shift @{$self->{'subs_todo'}};
 338     my $cv = $ent->[1];
 339     my $gv = $cv->GV;
 340     my $name = $self->gv_name($gv);
 341     if ($ent->[2]) {
 342         return "format $name =\n"
 343             . $self->deparse_format($ent->[1]). "\n";
 344     } else {
 345         $self->{'subs_declared'}{$name} = 1;
 346         if ($name eq "BEGIN") {
 347             my $use_dec = $self->begin_is_use($cv);
 348             if (defined ($use_dec) and $self->{'expand'} < 5) {
 349                 return () if 0 == length($use_dec);
 350                 return $use_dec;
 351             }
 352         }
 353         my $l = '';
 354         if ($self->{'linenums'}) {
 355             my $line = $gv->LINE;
 356             my $file = $gv->FILE;
 357             $l = "\n\f#line $line \"$file\"\n";
 358         }
 359         my $p = '';
 360         if (class($cv->STASH) ne "SPECIAL") {
 361             my $stash = $cv->STASH->NAME;
 362             if ($stash ne $self->{'curstash'}) {
 363                 $p = "package $stash;\n";
 364                 $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
 365                 $self->{'curstash'} = $stash;
 366             }
 367             $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
 368         }
 369         return "${p}${l}sub $name " . $self->deparse_sub($cv);
 370     }
 371 }
 372
 373 # Return a "use" declaration for this BEGIN block, if appropriate
 374 sub begin_is_use {
 375     my ($self, $cv) = @_;
 376     my $root = $cv->ROOT;
 377     local @$self{qw'curcv curcvlex'} = ($cv);
 378 #require B::Debug;
 379 #B::walkoptree($cv->ROOT, "debug");
 380     my $lineseq = $root->first;
 381     return if $lineseq->name ne "lineseq";
 382
 383     my $req_op = $lineseq->first->sibling;
 384     return if $req_op->name ne "require";
 385
 386     my $module;
 387     if ($req_op->first->private & OPpCONST_BARE) {
 388         # Actually it should always be a bareword
 389         $module = $self->const_sv($req_op->first)->PV;
 390         $module =~ s[/][::]g;
 391         $module =~ s/.pm$//;
 392     }
 393     else {
 394         $module = $self->const($self->const_sv($req_op->first), 6);
 395     }
 396
 397     my $version;
 398     my $version_op = $req_op->sibling;
 399     return if class($version_op) eq "NULL";
 400     if ($version_op->name eq "lineseq") {
 401         # We have a version parameter; skip nextstate & pushmark
 402         my $constop = $version_op->first->next->next;
 403
 404         return unless $self->const_sv($constop)->PV eq $module;
 405         $constop = $constop->sibling;
 406         $version = $self->const_sv($constop);
 407         if (class($version) eq "IV") {
 408             $version = $version->int_value;
 409         } elsif (class($version) eq "NV") {
 410             $version = $version->NV;
 411         } elsif (class($version) ne "PVMG") {
 412             # Includes PVIV and PVNV
 413             $version = $version->PV;
 414         } else {
 415             # version specified as a v-string
 416             $version = 'v'.join '.', map ord, split //, $version->PV;
 417         }
 418         $constop = $constop->sibling;
 419         return if $constop->name ne "method_named";
 420         return if $self->const_sv($constop)->PV ne "VERSION";
 421     }
 422
 423     $lineseq = $version_op->sibling;
 424     return if $lineseq->name ne "lineseq";
 425     my $entersub = $lineseq->first->sibling;
 426     if ($entersub->name eq "stub") {
 427         return "use $module $version ();\n" if defined $version;
 428         return "use $module ();\n";
 429     }
 430     return if $entersub->name ne "entersub";
 431
 432     # See if there are import arguments
 433     my $args = '';
 434
 435     my $svop = $entersub->first->sibling; # Skip over pushmark
 436     return unless $self->const_sv($svop)->PV eq $module;
 437
 438     # Pull out the arguments
 439     for ($svop=$svop->sibling; $svop->name ne "method_named";
 440                 $svop = $svop->sibling) {
 441         $args .= ", " if length($args);
 442         $args .= $self->deparse($svop, 6);
 443     }
 444
 445     my $use = 'use';
 446     my $method_named = $svop;
 447     return if $method_named->name ne "method_named";
 448     my $method_name = $self->const_sv($method_named)->PV;
 449
 450     if ($method_name eq "unimport") {
 451         $use = 'no';
 452     }
 453
 454     # Certain pragmas are dealt with using hint bits,
 455     # so we ignore them here
 456     if ($module eq 'strict' || $module eq 'integer'
 457         || $module eq 'bytes' || $module eq 'warnings'
 458         || $module eq 'feature') {
 459         return "";
 460     }
 461
 462     if (defined $version && length $args) {
 463         return "$use $module $version ($args);\n";
 464     } elsif (defined $version) {
 465         return "$use $module $version;\n";
 466     } elsif (length $args) {
 467         return "$use $module ($args);\n";
 468     } else {
 469         return "$use $module;\n";
 470     }
 471 }
 472
 473 sub stash_subs {
 474     my ($self, $pack, $seen) = @_;
 475     my (@ret, $stash);
 476     if (!defined $pack) {
 477         $pack = '';
 478         $stash = \%::;
 479     }
 480     else {
 481         $pack =~ s/(::)?$/::/;
 482         no strict 'refs';
 483         $stash = \%{"main::$pack"};
 484     }
 485     return
 486         if ($seen ||= {})->{
 487             $INC{"overload.pm"} ? overload::StrVal($stash) : $stash
 488            }++;
 489     my %stash = svref_2object($stash)->ARRAY;
 490     while (my ($key, $val) = each %stash) {
 491         my $class = class($val);
 492         if ($class eq "PV") {
 493             # Just a prototype. As an ugly but fairly effective way
 494             # to find out if it belongs here is to see if the AUTOLOAD
 495             # (if any) for the stash was defined in one of our files.
 496             my $A = $stash{"AUTOLOAD"};
 497             if (defined ($A) && class($A) eq "GV" && defined($A->CV)
 498                 && class($A->CV) eq "CV") {
 499                 my $AF = $A->FILE;
 500                 next unless $AF eq $0 || exists $self->{'files'}{$AF};
 501             }
 502             push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
 503         } elsif ($class eq "IV" && !($val->FLAGS & SVf_ROK)) {
 504             # Just a name. As above.
 505             # But skip proxy constant subroutines, as some form of perl-space
 506             # visible code must have created them, be it a use statement, or
 507             # some direct symbol-table manipulation code that we will Deparse
 508             my $A = $stash{"AUTOLOAD"};
 509             if (defined ($A) && class($A) eq "GV" && defined($A->CV)
 510                 && class($A->CV) eq "CV") {
 511                 my $AF = $A->FILE;
 512                 next unless $AF eq $0 || exists $self->{'files'}{$AF};
 513             }
 514             push @{$self->{'protos_todo'}}, [$pack . $key, undef];
 515         } elsif ($class eq "GV") {
 516             if (class(my $cv = $val->CV) ne "SPECIAL") {
 517                 next if $self->{'subs_done'}{$$val}++;
 518                 next if $$val != ${$cv->GV};   # Ignore imposters
 519                 $self->todo($cv, 0);
 520             }
 521             if (class(my $cv = $val->FORM) ne "SPECIAL") {
 522                 next if $self->{'forms_done'}{$$val}++;
 523                 next if $$val != ${$cv->GV};   # Ignore imposters
 524                 $self->todo($cv, 1);
 525             }
 526             if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
 527                 $self->stash_subs($pack . $key, $seen);
 528             }
 529         }
 530     }
 531 }
 532
 533 sub print_protos {
 534     my $self = shift;
 535     my $ar;
 536     my @ret;
 537     foreach $ar (@{$self->{'protos_todo'}}) {
 538         my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
 539         push @ret, "sub " . $ar->[0] .  "$proto;\n";
 540     }
 541     delete $self->{'protos_todo'};
 542     return @ret;
 543 }
 544
 545 sub style_opts {
 546     my $self = shift;
 547     my $opts = shift;
 548     my $opt;
 549     while (length($opt = substr($opts, 0, 1))) {
 550         if ($opt eq "C") {
 551             $self->{'cuddle'} = " ";
 552             $opts = substr($opts, 1);
 553         } elsif ($opt eq "i") {
 554             $opts =~ s/^i(\d+)//;
 555             $self->{'indent_size'} = $1;
 556         } elsif ($opt eq "T") {
 557             $self->{'use_tabs'} = 1;
 558             $opts = substr($opts, 1);
 559         } elsif ($opt eq "v") {
 560             $opts =~ s/^v([^.]*)(.|$)//;
 561             $self->{'ex_const'} = $1;
 562         }
 563     }
 564 }
 565
 566 sub new {
 567     my $class = shift;
 568     my $self = bless {}, $class;
 569     $self->{'cuddle'} = "\n";
 570     $self->{'curcop'} = undef;
 571     $self->{'curstash'} = "main";
 572     $self->{'ex_const'} = "'???'";
 573     $self->{'expand'} = 0;
 574     $self->{'files'} = {};
 575     $self->{'indent_size'} = 4;
 576     $self->{'linenums'} = 0;
 577     $self->{'parens'} = 0;
 578     $self->{'subs_todo'} = [];
 579     $self->{'unquote'} = 0;
 580     $self->{'use_dumper'} = 0;
 581     $self->{'use_tabs'} = 0;
 582
 583     $self->{'ambient_arybase'} = 0;
 584     $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
 585     $self->{'ambient_hints'} = 0;
 586     $self->{'ambient_hinthash'} = undef;
 587     $self->init();
 588
 589     while (my $arg = shift @_) {
 590         if ($arg eq "-d") {
 591             $self->{'use_dumper'} = 1;
 592             require Data::Dumper;
 593         } elsif ($arg =~ /^-f(.*)/) {
 594             $self->{'files'}{$1} = 1;
 595         } elsif ($arg eq "-l") {
 596             $self->{'linenums'} = 1;
 597         } elsif ($arg eq "-p") {
 598             $self->{'parens'} = 1;
 599         } elsif ($arg eq "-P") {
 600             $self->{'noproto'} = 1;
 601         } elsif ($arg eq "-q") {
 602             $self->{'unquote'} = 1;
 603         } elsif (substr($arg, 0, 2) eq "-s") {
 604             $self->style_opts(substr $arg, 2);
 605         } elsif ($arg =~ /^-x(\d)$/) {
 606             $self->{'expand'} = $1;
 607         }
 608     }
 609     return $self;
 610 }
 611
 612 {
 613     # Mask out the bits that L<warnings::register> uses
 614     my $WARN_MASK;
 615     BEGIN {
 616         $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
 617     }
 618     sub WARN_MASK () {
 619         return $WARN_MASK;
 620     }
 621 }
 622
 623 # Initialise the contextual information, either from
 624 # defaults provided with the ambient_pragmas method,
 625 # or from perl's own defaults otherwise.
 626 sub init {
 627     my $self = shift;
 628
 629     $self->{'arybase'}  = $self->{'ambient_arybase'};
 630     $self->{'warnings'} = defined ($self->{'ambient_warnings'})
 631                                 ? $self->{'ambient_warnings'} & WARN_MASK
 632                                 : undef;
 633     $self->{'hints'}    = $self->{'ambient_hints'};
 634     $self->{'hints'} &= 0xFF if $] < 5.009;
 635     $self->{'hinthash'} = $self->{'ambient_hinthash'};
 636
 637     # also a convenient place to clear out subs_declared
 638     delete $self->{'subs_declared'};
 639 }
 640
 641 sub compile {
 642     my(@args) = @_;
 643     return sub {
 644         my $self = B::Deparse->new(@args);
 645         # First deparse command-line args
 646         if (defined $^I) { # deparse -i
 647             print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
 648         }
 649         if ($^W) { # deparse -w
 650             print qq(BEGIN { \$^W = $^W; }\n);
 651         }
 652         if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
 653             my $fs = perlstring($/) || 'undef';
 654             my $bs = perlstring($O::savebackslash) || 'undef';
 655             print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
 656         }
 657         my @BEGINs  = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
 658         my @UNITCHECKs = B::unitcheck_av->isa("B::AV")
 659             ? B::unitcheck_av->ARRAY
 660             : ();
 661         my @CHECKs  = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
 662         my @INITs   = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
 663         my @ENDs    = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
 664         for my $block (@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs) {
 665             $self->todo($block, 0);
 666         }
 667         $self->stash_subs();
 668         local($SIG{"__DIE__"}) =
 669           sub {
 670               if ($self->{'curcop'}) {
 671                   my $cop = $self->{'curcop'};
 672                   my($line, $file) = ($cop->line, $cop->file);
 673                   print STDERR "While deparsing $file near line $line,\n";
 674               }
 675             };
 676         $self->{'curcv'} = main_cv;
 677         $self->{'curcvlex'} = undef;
 678         print $self->print_protos;
 679         @{$self->{'subs_todo'}} =
 680           sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
 681         print $self->indent($self->deparse_root(main_root)), "\n"
 682           unless null main_root;
 683         my @text;
 684         while (scalar(@{$self->{'subs_todo'}})) {
 685             push @text, $self->next_todo;
 686         }
 687         print $self->indent(join("", @text)), "\n" if @text;
 688
 689         # Print __DATA__ section, if necessary
 690         no strict 'refs';
 691         my $laststash = defined $self->{'curcop'}
 692             ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
 693         if (defined *{$laststash."::DATA"}{IO}) {
 694             print "package $laststash;\n"
 695                 unless $laststash eq $self->{'curstash'};
 696             print "__DATA__\n";
 697             print readline(*{$laststash."::DATA"});
 698         }
 699     }
 700 }
 701
 702 sub coderef2text {
 703     my $self = shift;
 704     my $sub = shift;
 705     croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
 706
 707     $self->init();
 708     return $self->indent($self->deparse_sub(svref_2object($sub)));
 709 }
 710
 711 my %strict_bits = do {
 712     local %^H;
 713     map +($_ => strict::bits($_)), qw/refs subs vars/
 714 };
 715
 716 sub ambient_pragmas {
 717     my $self = shift;
 718     my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
 719
 720     while (@_ > 1) {
 721         my $name = shift();
 722         my $val  = shift();
 723
 724         if ($name eq 'strict') {
 725             require strict;
 726
 727             if ($val eq 'none') {
 728                 $hint_bits &= $strict_bits{$_} for qw/refs subs vars/;
 729                 next();
 730             }
 731
 732             my @names;
 733             if ($val eq "all") {
 734                 @names = qw/refs subs vars/;
 735             }
 736             elsif (ref $val) {
 737                 @names = @$val;
 738             }
 739             else {
 740                 @names = split' ', $val;
 741             }
 742             $hint_bits |= $strict_bits{$_} for @names;
 743         }
 744
 745         elsif ($name eq '$[') {
 746             if (OPpCONST_ARYBASE) {
 747                 $arybase = $val;
 748             } else {
 749                 croak "\$[ can't be non-zero on this perl" unless $val == 0;
 750             }
 751         }
 752
 753         elsif ($name eq 'integer'
 754             || $name eq 'bytes'
 755             || $name eq 'utf8') {
 756             require "$name.pm";
 757             if ($val) {
 758                 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
 759             }
 760             else {
 761                 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
 762             }
 763         }
 764
 765         elsif ($name eq 're') {
 766             require re;
 767             if ($val eq 'none') {
 768                 $hint_bits &= ~re::bits(qw/taint eval/);
 769                 next();
 770             }
 771
 772             my @names;
 773             if ($val eq 'all') {
 774                 @names = qw/taint eval/;
 775             }
 776             elsif (ref $val) {
 777                 @names = @$val;
 778             }
 779             else {
 780                 @names = split' ',$val;
 781             }
 782             $hint_bits |= re::bits(@names);
 783         }
 784
 785         elsif ($name eq 'warnings') {
 786             if ($val eq 'none') {
 787                 $warning_bits = $warnings::NONE;
 788                 next();
 789             }
 790
 791             my @names;
 792             if (ref $val) {
 793                 @names = @$val;
 794             }
 795             else {
 796                 @names = split/\s+/, $val;
 797             }
 798
 799             $warning_bits = $warnings::NONE if !defined ($warning_bits);
 800             $warning_bits |= warnings::bits(@names);
 801         }
 802
 803         elsif ($name eq 'warning_bits') {
 804             $warning_bits = $val;
 805         }
 806
 807         elsif ($name eq 'hint_bits') {
 808             $hint_bits = $val;
 809         }
 810
 811         elsif ($name eq '%^H') {
 812             $hinthash = $val;
 813         }
 814
 815         else {
 816             croak "Unknown pragma type: $name";
 817         }
 818     }
 819     if (@_) {
 820         croak "The ambient_pragmas method expects an even number of args";
 821     }
 822
 823     $self->{'ambient_arybase'} = $arybase;
 824     $self->{'ambient_warnings'} = $warning_bits;
 825     $self->{'ambient_hints'} = $hint_bits;
 826     $self->{'ambient_hinthash'} = $hinthash;
 827 }
 828
 829 # This method is the inner loop, so try to keep it simple
 830 sub deparse {
 831     my $self = shift;
 832     my($op, $cx) = @_;
 833
 834     Carp::confess("Null op in deparse") if !defined($op)
 835                                         || class($op) eq "NULL";
 836     my $meth = "pp_" . $op->name;
 837     return $self->$meth($op, $cx);
 838 }
 839
 840 sub indent {
 841     my $self = shift;
 842     my $txt = shift;
 843     my @lines = split(/\n/, $txt);
 844     my $leader = "";
 845     my $level = 0;
 846     my $line;
 847     for $line (@lines) {
 848         my $cmd = substr($line, 0, 1);
 849         if ($cmd eq "\t" or $cmd eq "\b") {
 850             $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
 851             if ($self->{'use_tabs'}) {
 852                 $leader = "\t" x ($level / 8) . " " x ($level % 8);
 853             } else {
 854                 $leader = " " x $level;
 855             }
 856             $line = substr($line, 1);
 857         }
 858         if (substr($line, 0, 1) eq "\f") {
 859             $line = substr($line, 1); # no indent
 860         } else {
 861             $line = $leader . $line;
 862         }
 863         $line =~ s/\cK;?//g;
 864     }
 865     return join("\n", @lines);
 866 }
 867
 868 sub deparse_sub {
 869     my $self = shift;
 870     my $cv = shift;
 871     my $proto = "";
 872 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
 873 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
 874     local $self->{'curcop'} = $self->{'curcop'};
 875     if ($cv->FLAGS & SVf_POK) {
 876         $proto = "(". $cv->PV . ") ";
 877     }
 878     if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
 879         $proto .= ": ";
 880         $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
 881         $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
 882         $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
 883     }
 884
 885     local($self->{'curcv'}) = $cv;
 886     local($self->{'curcvlex'});
 887     local(@$self{qw'curstash warnings hints hinthash'})
 888                 = @$self{qw'curstash warnings hints hinthash'};
 889     my $body;
 890     if (not null $cv->ROOT) {
 891         my $lineseq = $cv->ROOT->first;
 892         if ($lineseq->name eq "lineseq") {
 893             my @ops;
 894             for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
 895                 push @ops, $o;
 896             }
 897             $body = $self->lineseq(undef, @ops).";";
 898             my $scope_en = $self->find_scope_en($lineseq);
 899             if (defined $scope_en) {
 900                 my $subs = join"", $self->seq_subs($scope_en);
 901                 $body .= ";\n$subs" if length($subs);
 902             }
 903         }
 904         else {
 905             $body = $self->deparse($cv->ROOT->first, 0);
 906         }
 907     }
 908     else {
 909         my $sv = $cv->const_sv;
 910         if ($$sv) {
 911             # uh-oh. inlinable sub... format it differently
 912             return $proto . "{ " . $self->const($sv, 0) . " }\n";
 913         } else { # XSUB? (or just a declaration)
 914             return "$proto;\n";
 915         }
 916     }
 917     return $proto ."{\n\t$body\n\b}" ."\n";
 918 }
 919
 920 sub deparse_format {
 921     my $self = shift;
 922     my $form = shift;
 923     my @text;
 924     local($self->{'curcv'}) = $form;
 925     local($self->{'curcvlex'});
 926     local($self->{'in_format'}) = 1;
 927     local(@$self{qw'curstash warnings hints hinthash'})
 928                 = @$self{qw'curstash warnings hints hinthash'};
 929     my $op = $form->ROOT;
 930     my $kid;
 931     return "\f." if $op->first->name eq 'stub'
 932                 || $op->first->name eq 'nextstate';
 933     $op = $op->first->first; # skip leavewrite, lineseq
 934     while (not null $op) {
 935         $op = $op->sibling; # skip nextstate
 936         my @exprs;
 937         $kid = $op->first->sibling; # skip pushmark
 938         push @text, "\f".$self->const_sv($kid)->PV;
 939         $kid = $kid->sibling;
 940         for (; not null $kid; $kid = $kid->sibling) {
 941             push @exprs, $self->deparse($kid, 0);
 942         }
 943         push @text, "\f".join(", ", @exprs)."\n" if @exprs;
 944         $op = $op->sibling;
 945     }
 946     return join("", @text) . "\f.";
 947 }
 948
 949 sub is_scope {
 950     my $op = shift;
 951     return $op->name eq "leave" || $op->name eq "scope"
 952       || $op->name eq "lineseq"
 953         || ($op->name eq "null" && class($op) eq "UNOP"
 954             && (is_scope($op->first) || $op->first->name eq "enter"));
 955 }
 956
 957 sub is_state {
 958     my $name = $_[0]->name;
 959     return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
 960 }
 961
 962 sub is_miniwhile { # check for one-line loop ('foo() while $y--')
 963     my $op = shift;
 964     return (!null($op) and null($op->sibling)
 965             and $op->name eq "null" and class($op) eq "UNOP"
 966             and (($op->first->name =~ /^(and|or)$/
 967                   and $op->first->first->sibling->name eq "lineseq")
 968                  or ($op->first->name eq "lineseq"
 969                      and not null $op->first->first->sibling
 970                      and $op->first->first->sibling->name eq "unstack")
 971                  ));
 972 }
 973
 974 # Check if the op and its sibling are the initialization and the rest of a
 975 # for (..;..;..) { ... } loop
 976 sub is_for_loop {
 977     my $op = shift;
 978     # This OP might be almost anything, though it won't be a
 979     # nextstate. (It's the initialization, so in the canonical case it
 980     # will be an sassign.) The sibling is (old style) a lineseq whose
 981     # first child is a nextstate and whose second is a leaveloop, or
 982     # (new style) an unstack whose sibling is a leaveloop.
 983     my $lseq = $op->sibling;
 984     return 0 unless !is_state($op) and !null($lseq);
 985     if ($lseq->name eq "lineseq") {
 986         if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
 987             && (my $sib = $lseq->first->sibling)) {
 988             return (!null($sib) && $sib->name eq "leaveloop");
 989         }
 990     } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) {
 991         my $sib = $lseq->sibling;
 992         return $sib && !null($sib) && $sib->name eq "leaveloop";
 993     }
 994     return 0;
 995 }
 996
 997 sub is_scalar {
 998     my $op = shift;
 999     return ($op->name eq "rv2sv" or
1000             $op->name eq "padsv" or
1001             $op->name eq "gv" or # only in array/hash constructs
1002             $op->flags & OPf_KIDS && !null($op->first)
1003               && $op->first->name eq "gvsv");
1004 }
1005
1006 sub maybe_parens {
1007     my $self = shift;
1008     my($text, $cx, $prec) = @_;
1009     if ($prec < $cx              # unary ops nest just fine
1010         or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
1011         or $self->{'parens'})
1012     {
1013         $text = "($text)";
1014         # In a unop, let parent reuse our parens; see maybe_parens_unop
1015         $text = "\cS" . $text if $cx == 16;
1016         return $text;
1017     } else {
1018         return $text;
1019     }
1020 }
1021
1022 # same as above, but get around the 'if it looks like a function' rule
1023 sub maybe_parens_unop {
1024     my $self = shift;
1025     my($name, $kid, $cx) = @_;
1026     if ($cx > 16 or $self->{'parens'}) {
1027         $kid =  $self->deparse($kid, 1);
1028         if ($name eq "umask" && $kid =~ /^\d+$/) {
1029             $kid = sprintf("%#o", $kid);
1030         }
1031         return $self->keyword($name) . "($kid)";
1032     } else {
1033         $kid = $self->deparse($kid, 16);
1034         if ($name eq "umask" && $kid =~ /^\d+$/) {
1035             $kid = sprintf("%#o", $kid);
1036         }
1037         $name = $self->keyword($name);
1038         if (substr($kid, 0, 1) eq "\cS") {
1039             # use kid's parens
1040             return $name . substr($kid, 1);
1041         } elsif (substr($kid, 0, 1) eq "(") {
1042             # avoid looks-like-a-function trap with extra parens
1043             # ('+' can lead to ambiguities)
1044             return "$name(" . $kid  . ")";
1045         } else {
1046             return "$name $kid";
1047         }
1048     }
1049 }
1050
1051 sub maybe_parens_func {
1052     my $self = shift;
1053     my($func, $text, $cx, $prec) = @_;
1054     if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
1055         return "$func($text)";
1056     } else {
1057         return "$func $text";
1058     }
1059 }
1060
1061 sub maybe_local {
1062     my $self = shift;
1063     my($op, $cx, $text) = @_;
1064     my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
1065     if ($op->private & (OPpLVAL_INTRO|$our_intro)
1066         and not $self->{'avoid_local'}{$$op}) {
1067         my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
1068         if( $our_local eq 'our' ) {
1069             if ( $text !~ /^\W(\w+::)*\w+\z/
1070              and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
1071             ) {
1072                 die "Unexpected our($text)\n";
1073             }
1074             $text =~ s/(\w+::)+//;
1075         }
1076         if (want_scalar($op)) {
1077             return "$our_local $text";
1078         } else {
1079             return $self->maybe_parens_func("$our_local", $text, $cx, 16);
1080         }
1081     } else {
1082         return $text;
1083     }
1084 }
1085
1086 sub maybe_targmy {
1087     my $self = shift;
1088     my($op, $cx, $func, @args) = @_;
1089     if ($op->private & OPpTARGET_MY) {
1090         my $var = $self->padname($op->targ);
1091         my $val = $func->($self, $op, 7, @args);
1092         return $self->maybe_parens("$var = $val", $cx, 7);
1093     } else {
1094         return $func->($self, $op, $cx, @args);
1095     }
1096 }
1097
1098 sub padname_sv {
1099     my $self = shift;
1100     my $targ = shift;
1101     return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
1102 }
1103
1104 sub maybe_my {
1105     my $self = shift;
1106     my($op, $cx, $text) = @_;
1107     if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
1108         my $my = $op->private & OPpPAD_STATE
1109             ? $self->keyword("state")
1110             : "my";
1111         if (want_scalar($op)) {
1112             return "$my $text";
1113         } else {
1114             return $self->maybe_parens_func($my, $text, $cx, 16);
1115         }
1116     } else {
1117         return $text;
1118     }
1119 }
1120
1121 # The following OPs don't have functions:
1122
1123 # pp_padany -- does not exist after parsing
1124
1125 sub AUTOLOAD {
1126     if ($AUTOLOAD =~ s/^.*::pp_//) {
1127         warn "unexpected OP_".uc $AUTOLOAD;
1128         return "XXX";
1129     } else {
1130         die "Undefined subroutine $AUTOLOAD called";
1131     }
1132 }
1133
1134 sub DESTROY {}  #       Do not AUTOLOAD
1135
1136 # $root should be the op which represents the root of whatever
1137 # we're sequencing here. If it's undefined, then we don't append
1138 # any subroutine declarations to the deparsed ops, otherwise we
1139 # append appropriate declarations.
1140 sub lineseq {
1141     my($self, $root, @ops) = @_;
1142     my($expr, @exprs);
1143
1144     my $out_cop = $self->{'curcop'};
1145     my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1146     my $limit_seq;
1147     if (defined $root) {
1148         $limit_seq = $out_seq;
1149         my $nseq;
1150         $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
1151         $limit_seq = $nseq if !defined($limit_seq)
1152                            or defined($nseq) && $nseq < $limit_seq;
1153     }
1154     $limit_seq = $self->{'limit_seq'}
1155         if defined($self->{'limit_seq'})
1156         && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1157     local $self->{'limit_seq'} = $limit_seq;
1158
1159     $self->walk_lineseq($root, \@ops,
1160                        sub { push @exprs, $_[0]} );
1161
1162     my $body = join(";\n", grep {length} @exprs);
1163     my $subs = "";
1164     if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
1165         $subs = join "\n", $self->seq_subs($limit_seq);
1166     }
1167     return join(";\n", grep {length} $body, $subs);
1168 }
1169
1170 sub scopeop {
1171     my($real_block, $self, $op, $cx) = @_;
1172     my $kid;
1173     my @kids;
1174
1175     local(@$self{qw'curstash warnings hints hinthash'})
1176                 = @$self{qw'curstash warnings hints hinthash'} if $real_block;
1177     if ($real_block) {
1178         $kid = $op->first->sibling; # skip enter
1179         if (is_miniwhile($kid)) {
1180             my $top = $kid->first;
1181             my $name = $top->name;
1182             if ($name eq "and") {
1183                 $name = "while";
1184             } elsif ($name eq "or") {
1185                 $name = "until";
1186             } else { # no conditional -> while 1 or until 0
1187                 return $self->deparse($top->first, 1) . " while 1";
1188             }
1189             my $cond = $top->first;
1190             my $body = $cond->sibling->first; # skip lineseq
1191             $cond = $self->deparse($cond, 1);
1192             $body = $self->deparse($body, 1);
1193             return "$body $name $cond";
1194         }
1195     } else {
1196         $kid = $op->first;
1197     }
1198     for (; !null($kid); $kid = $kid->sibling) {
1199         push @kids, $kid;
1200     }
1201     if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
1202         return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
1203     } else {
1204         my $lineseq = $self->lineseq($op, @kids);
1205         return (length ($lineseq) ? "$lineseq;" : "");
1206     }
1207 }
1208
1209 sub pp_scope { scopeop(0, @_); }
1210 sub pp_lineseq { scopeop(0, @_); }
1211 sub pp_leave { scopeop(1, @_); }
1212
1213 # This is a special case of scopeop and lineseq, for the case of the
1214 # main_root. The difference is that we print the output statements as
1215 # soon as we get them, for the sake of impatient users.
1216 sub deparse_root {
1217     my $self = shift;
1218     my($op) = @_;
1219     local(@$self{qw'curstash warnings hints hinthash'})
1220       = @$self{qw'curstash warnings hints hinthash'};
1221     my @kids;
1222     return if null $op->first; # Can happen, e.g., for Bytecode without -k
1223     for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
1224         push @kids, $kid;
1225     }
1226     $self->walk_lineseq($op, \@kids,
1227                         sub { print $self->indent($_[0].';');
1228                               print "\n" unless $_[1] == $#kids;
1229                           });
1230 }
1231
1232 sub walk_lineseq {
1233     my ($self, $op, $kids, $callback) = @_;
1234     my @kids = @$kids;
1235     for (my $i = 0; $i < @kids; $i++) {
1236         my $expr = "";
1237         if (is_state $kids[$i]) {
1238             $expr = $self->deparse($kids[$i++], 0);
1239             if ($i > $#kids) {
1240                 $callback->($expr, $i);
1241                 last;
1242             }
1243         }
1244         if (is_for_loop($kids[$i])) {
1245             $callback->($expr . $self->for_loop($kids[$i], 0),
1246                 $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
1247             next;
1248         }
1249         $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
1250         $expr =~ s/;\n?\z//;
1251         $callback->($expr, $i);
1252     }
1253 }
1254
1255 # The BEGIN {} is used here because otherwise this code isn't executed
1256 # when you run B::Deparse on itself.
1257 my %globalnames;
1258 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1259             "ENV", "ARGV", "ARGVOUT", "_"); }
1260
1261 sub gv_name {
1262     my $self = shift;
1263     my $gv = shift;
1264     my $raw = shift;
1265 Carp::confess() unless ref($gv) eq "B::GV";
1266     my $stash = $gv->STASH->NAME;
1267     my $name = $raw ? $gv->NAME : $gv->SAFENAME;
1268     if ($stash eq 'main' && $name =~ /^::/) {
1269         $stash = '::';
1270     }
1271     elsif (($stash eq 'main'
1272             && ($globalnames{$name} || $name =~ /^[^A-Za-z_:]/))
1273         or ($stash eq $self->{'curstash'} && !$globalnames{$name}
1274             && ($stash eq 'main' || $name !~ /::/))
1275           )
1276     {
1277         $stash = "";
1278     } else {
1279         $stash = $stash . "::";
1280     }
1281     if (!$raw and $name =~ /^(\^..|{)/) {
1282         $name = "{$name}";       # ${^WARNING_BITS}, etc and ${
1283     }
1284     return $stash . $name;
1285 }
1286
1287 # Return the name to use for a stash variable.
1288 # If a lexical with the same name is in scope, or
1289 # if strictures are enabled, it may need to be
1290 # fully-qualified.
1291 sub stash_variable {
1292     my ($self, $prefix, $name, $cx) = @_;
1293
1294     return "$prefix$name" if $name =~ /::/;
1295
1296     unless ($prefix eq '$' || $prefix eq '@' || #'
1297             $prefix eq '%' || $prefix eq '$#') {
1298         return "$prefix$name";
1299     }
1300
1301     if ($name =~ /^[^\w+-]$/) {
1302       if (defined $cx && $cx == 26) {
1303         if ($prefix eq '@') {
1304             return "$prefix\{$name}";
1305         }
1306         elsif ($name eq '#') { return '${#}' } #  "${#}a" vs "$#a"
1307       }
1308       if ($prefix eq '$#') {
1309         return "\$#{$name}";
1310       }
1311     }
1312
1313     return $prefix . $self->maybe_qualify($prefix, $name);
1314 }
1315
1316 # Return just the name, without the prefix.  It may be returned as a quoted
1317 # string.  The second return value is a boolean indicating that.
1318 sub stash_variable_name {
1319     my($self, $prefix, $gv) = @_;
1320     my $name = $self->gv_name($gv, 1);
1321     $name = $self->maybe_qualify($prefix,$name);
1322     if ($name =~ /^(?:\S|(?!\d)[\ca-\cz]?(?:\w|::)*|\d+)\z/) {
1323         $name =~ s/^([\ca-\cz])/'^'.($1|'@')/e;
1324         $name =~ /^(\^..|{)/ and $name = "{$name}";
1325         return $name, 0; # not quoted
1326     }
1327     else {
1328         single_delim("q", "'", $name), 1;
1329     }
1330 }
1331
1332 sub maybe_qualify {
1333     my ($self,$prefix,$name) = @_;
1334     my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1335     return $name if !$prefix || $name =~ /::/;
1336     return $self->{'curstash'}.'::'. $name
1337         if
1338             $name =~ /^(?!\d)\w/         # alphabetic
1339          && $v    !~ /^\$[ab]\z/         # not $a or $b
1340          && !$globalnames{$name}         # not a global name
1341          && $self->{hints} & $strict_bits{vars}  # strict vars
1342          && !$self->lex_in_scope($v,1)   # no "our"
1343       or $self->lex_in_scope($v);        # conflicts with "my" variable
1344     return $name;
1345 }
1346
1347 sub lex_in_scope {
1348     my ($self, $name, $our) = @_;
1349     substr $name, 0, 0, = $our ? 'o' : 'm'; # our/my
1350     $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1351
1352     return 0 if !defined($self->{'curcop'});
1353     my $seq = $self->{'curcop'}->cop_seq;
1354     return 0 if !exists $self->{'curcvlex'}{$name};
1355     for my $a (@{$self->{'curcvlex'}{$name}}) {
1356         my ($st, $en) = @$a;
1357         return 1 if $seq > $st && $seq <= $en;
1358     }
1359     return 0;
1360 }
1361
1362 sub populate_curcvlex {
1363     my $self = shift;
1364     for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1365         my $padlist = $cv->PADLIST;
1366         # an undef CV still in lexical chain
1367         next if class($padlist) eq "SPECIAL";
1368         my @padlist = $padlist->ARRAY;
1369         my @ns = $padlist[0]->ARRAY;
1370
1371         for (my $i=0; $i<@ns; ++$i) {
1372             next if class($ns[$i]) eq "SPECIAL";
1373             if (class($ns[$i]) eq "PV") {
1374                 # Probably that pesky lexical @_
1375                 next;
1376             }
1377             my $name = $ns[$i]->PVX;
1378             my ($seq_st, $seq_en) =
1379                 ($ns[$i]->FLAGS & SVf_FAKE)
1380                     ? (0, 999999)
1381                     : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH);
1382
1383             push @{$self->{'curcvlex'}{
1384                         ($ns[$i]->FLAGS & SVpad_OUR ? 'o' : 'm') . $name
1385                   }}, [$seq_st, $seq_en];
1386         }
1387     }
1388 }
1389
1390 sub find_scope_st { ((find_scope(@_))[0]); }
1391 sub find_scope_en { ((find_scope(@_))[1]); }
1392
1393 # Recurses down the tree, looking for pad variable introductions and COPs
1394 sub find_scope {
1395     my ($self, $op, $scope_st, $scope_en) = @_;
1396     carp("Undefined op in find_scope") if !defined $op;
1397     return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1398
1399     my @queue = ($op);
1400     while(my $op = shift @queue ) {
1401         for (my $o=$op->first; $$o; $o=$o->sibling) {
1402             if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1403                 my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW);
1404                 my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH;
1405                 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1406                 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1407                 return ($scope_st, $scope_en);
1408             }
1409             elsif (is_state($o)) {
1410                 my $c = $o->cop_seq;
1411                 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1412                 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1413                 return ($scope_st, $scope_en);
1414             }
1415             elsif ($o->flags & OPf_KIDS) {
1416                 unshift (@queue, $o);
1417             }
1418         }
1419     }
1420
1421     return ($scope_st, $scope_en);
1422 }
1423
1424 # Returns a list of subs which should be inserted before the COP
1425 sub cop_subs {
1426     my ($self, $op, $out_seq) = @_;
1427     my $seq = $op->cop_seq;
1428     # If we have nephews, then our sequence number indicates
1429     # the cop_seq of the end of some sort of scope.
1430     if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1431         and my $nseq = $self->find_scope_st($op->sibling) ) {
1432         $seq = $nseq;
1433     }
1434     $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1435     return $self->seq_subs($seq);
1436 }
1437
1438 sub seq_subs {
1439     my ($self, $seq) = @_;
1440     my @text;
1441 #push @text, "# ($seq)\n";
1442
1443     return "" if !defined $seq;
1444     while (scalar(@{$self->{'subs_todo'}})
1445            and $seq > $self->{'subs_todo'}[0][0]) {
1446         push @text, $self->next_todo;
1447     }
1448     return @text;
1449 }
1450
1451 my $feature_bundle_mask = 0x1c000000;
1452
1453 # Notice how subs and formats are inserted between statements here;
1454 # also $[ assignments and pragmas.
1455 sub pp_nextstate {
1456     my $self = shift;
1457     my($op, $cx) = @_;
1458     $self->{'curcop'} = $op;
1459     my @text;
1460     push @text, $self->cop_subs($op);
1461     my $stash = $op->stashpv;
1462     if ($stash ne $self->{'curstash'}) {
1463         push @text, "package $stash;\n";
1464         $self->{'curstash'} = $stash;
1465     }
1466
1467     if (OPpCONST_ARYBASE && $self->{'arybase'} != $op->arybase) {
1468         push @text, '$[ = '. $op->arybase .";\n";
1469         $self->{'arybase'} = $op->arybase;
1470     }
1471
1472     my $warnings = $op->warnings;
1473     my $warning_bits;
1474     if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1475         $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
1476     }
1477     elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1478         $warning_bits = $warnings::NONE;
1479     }
1480     elsif ($warnings->isa("B::SPECIAL")) {
1481         $warning_bits = undef;
1482     }
1483     else {
1484         $warning_bits = $warnings->PV & WARN_MASK;
1485     }
1486
1487     if (defined ($warning_bits) and
1488        !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1489         push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1490         $self->{'warnings'} = $warning_bits;
1491     }
1492
1493     my $hints = $] < 5.008009 ? $op->private : $op->hints;
1494     my $old_hints = $self->{'hints'};
1495     if ($self->{'hints'} != $hints) {
1496         push @text, declare_hints($self->{'hints'}, $hints);
1497         $self->{'hints'} = $hints;
1498     }
1499
1500     my $newhh;
1501     if ($] > 5.009) {
1502         $newhh = $op->hints_hash->HASH;
1503     }
1504
1505     if ($] >= 5.015006) {
1506         # feature bundle hints
1507         my $from = $old_hints & $feature_bundle_mask;
1508         my $to   = $    hints & $feature_bundle_mask;
1509         if ($from != $to) {
1510             require feature;
1511             if ($to == $feature_bundle_mask) {
1512                 if ($self->{'hinthash'}) {
1513                     delete $self->{'hinthash'}{$_}
1514                         for grep /^feature_/, keys %{$self->{'hinthash'}};
1515                 }
1516                 else { $self->{'hinthash'} = {} }
1517                 local $^H = $from;
1518                 %{$self->{'hinthash'}} = (
1519                     %{$self->{'hinthash'}},
1520                     map +($feature::feature{$_} => 1),
1521                          @{feature::current_bundle()},
1522                 );
1523             }
1524             else {
1525                 my $bundle =
1526                     $feature::hint_bundles[$to >> $feature::hint_shift];
1527                 $bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12
1528                 push @text, "no feature;\n",
1529                             "use feature ':$bundle';\n";
1530             }
1531         }
1532     }
1533
1534     if ($] > 5.009) {
1535         push @text, declare_hinthash(
1536             $self->{'hinthash'}, $newhh,
1537             $self->{indent_size}, $self->{hints},
1538         );
1539         $self->{'hinthash'} = $newhh;
1540     }
1541
1542     # This should go after of any branches that add statements, to
1543     # increase the chances that it refers to the same line it did in
1544     # the original program.
1545     if ($self->{'linenums'}) {
1546         push @text, "\f#line " . $op->line .
1547           ' "' . $op->file, qq'"\n';
1548     }
1549
1550     push @text, $op->label . ": " if $op->label;
1551
1552     return join("", @text);
1553 }
1554
1555 sub declare_warnings {
1556     my ($from, $to) = @_;
1557     if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
1558         return "use warnings;\n";
1559     }
1560     elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
1561         return "no warnings;\n";
1562     }
1563     return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n";
1564 }
1565
1566 sub declare_hints {
1567     my ($from, $to) = @_;
1568     my $use = $to   & ~$from;
1569     my $no  = $from & ~$to;
1570     my $decls = "";
1571     for my $pragma (hint_pragmas($use)) {
1572         $decls .= "use $pragma;\n";
1573     }
1574     for my $pragma (hint_pragmas($no)) {
1575         $decls .= "no $pragma;\n";
1576     }
1577     return $decls;
1578 }
1579
1580 # Internal implementation hints that the core sets automatically, so don't need
1581 # (or want) to be passed back to the user
1582 my %ignored_hints = (
1583     'open<' => 1,
1584     'open>' => 1,
1585     ':'     => 1,
1586     'strict/refs' => 1,
1587     'strict/subs' => 1,
1588     'strict/vars' => 1,
1589 );
1590
1591 my %rev_feature;
1592
1593 sub declare_hinthash {
1594     my ($from, $to, $indent, $hints) = @_;
1595     my $doing_features =
1596         ($hints & $feature_bundle_mask) == $feature_bundle_mask;
1597     my @decls;
1598     my @features;
1599     my @unfeatures; # bugs?
1600     for my $key (sort keys %$to) {
1601         next if $ignored_hints{$key};
1602         my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6;
1603         next if $is_feature and not $doing_features;
1604         if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) {
1605             push(@features, $key), next if $is_feature;
1606             push @decls,
1607                 qq(\$^H{) . single_delim("q", "'", $key) . qq(} = )
1608               . (
1609                    defined $to->{$key}
1610                         ? single_delim("q", "'", $to->{$key})
1611                         : 'undef'
1612                 )
1613               . qq(;);
1614         }
1615     }
1616     for my $key (sort keys %$from) {
1617         next if $ignored_hints{$key};
1618         my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6;
1619         next if $is_feature and not $doing_features;
1620         if (!exists $to->{$key}) {
1621             push(@unfeatures, $key), next if $is_feature;
1622             push @decls, qq(delete \$^H{'$key'};);
1623         }
1624     }
1625     my @ret;
1626     if (@features || @unfeatures) {
1627         require feature;
1628         if (!%rev_feature) { %rev_feature = reverse %feature::feature }
1629     }
1630     if (@features) {
1631         push @ret, "use feature "
1632                  . join(", ", map "'$rev_feature{$_}'", @features) . ";\n";
1633     }
1634     if (@unfeatures) {
1635         push @ret, "no feature "
1636                  . join(", ", map "'$rev_feature{$_}'", @unfeatures)
1637                  . ";\n";
1638     }
1639     @decls and
1640         push @ret,
1641              join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n";
1642     return @ret;
1643 }
1644
1645 sub hint_pragmas {
1646     my ($bits) = @_;
1647     my (@pragmas, @strict);
1648     push @pragmas, "integer" if $bits & 0x1;
1649     for (sort keys %strict_bits) {
1650         push @strict, "'$_'" if $bits & $strict_bits{$_};
1651     }
1652     if (@strict == keys %strict_bits) {
1653         push @pragmas, "strict";
1654     }
1655     elsif (@strict) {
1656         push @pragmas, "strict " . join ', ', @strict;
1657     }
1658     push @pragmas, "bytes" if $bits & 0x8;
1659     return @pragmas;
1660 }
1661
1662 sub pp_dbstate { pp_nextstate(@_) }
1663 sub pp_setstate { pp_nextstate(@_) }
1664
1665 sub pp_unstack { return "" } # see also leaveloop
1666
1667 my %feature_keywords = (
1668   # keyword => 'feature',
1669     state   => 'state',
1670     say     => 'say',
1671     given   => 'switch',
1672     when    => 'switch',
1673     default => 'switch',
1674     break   => 'switch',
1675     evalbytes=>'evalbytes',
1676     __SUB__ => '__SUB__',
1677    fc       => 'fc',
1678 );
1679
1680 sub keyword {
1681     my $self = shift;
1682     my $name = shift;
1683     return $name if $name =~ /^CORE::/; # just in case
1684     if (exists $feature_keywords{$name}) {
1685         my $hh;
1686         my $hints = $self->{hints} & $feature_bundle_mask;
1687         if ($hints && $hints != $feature_bundle_mask) {
1688             require feature;
1689             local $^H = $self->{hints};
1690             # Shh! Keep quite about this function.  It is not to be
1691             # relied upon.
1692             $hh = { map +($_ => 1), feature::current_bundle() };
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, 16)) =~ s/^\cS//;
2162         $name .= " $kid";
2163     }
2164     return $self->maybe_parens($name, $cx, 16);
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(undef,$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, @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_bundle_mask
4550           && ($self->{hints} & $feature_bundle_mask)
4551                != $feature_bundle_mask
4552           && do {
4553                 require feature;
4554                 $self->{hints} & $feature::hint_uni8bit;
4555              }
4556   ) {
4557         $flags .= 'd';
4558     }
4559     $flags;
4560 }
4561
4562 # osmic acid -- see osmium tetroxide
4563
4564 my %matchwords;
4565 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
4566     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
4567     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
4568
4569 sub matchop {
4570     my $self = shift;
4571     my($op, $cx, $name, $delim) = @_;
4572     my $kid = $op->first;
4573     my ($binop, $var, $re) = ("", "", "");
4574     if ($op->flags & OPf_STACKED) {
4575         $binop = 1;
4576         $var = $self->deparse($kid, 20);
4577         $kid = $kid->sibling;
4578     }
4579     my $quote = 1;
4580     my $pmflags = $op->pmflags;
4581     my $extended = ($pmflags & PMf_EXTENDED);
4582     my $rhs_bound_to_defsv;
4583     if (null $kid) {
4584         my $unbacked = re_unback($op->precomp);
4585         if ($extended) {
4586             $re = re_uninterp_extended(escape_extended_re($unbacked));
4587         } else {
4588             $re = re_uninterp(escape_str(re_unback($op->precomp)));
4589         }
4590     } elsif ($kid->name ne 'regcomp') {
4591         carp("found ".$kid->name." where regcomp expected");
4592     } else {
4593         ($re, $quote) = $self->regcomp($kid, 21, $extended);
4594         my $matchop = $kid->first->first;
4595         if ($matchop->name =~ /^(?:match|transr?|subst)\z/
4596            && $matchop->flags & OPf_SPECIAL) {
4597             $rhs_bound_to_defsv = 1;
4598         }
4599     }
4600     my $flags = "";
4601     $flags .= "c" if $pmflags & PMf_CONTINUE;
4602     $flags .= $self->re_flags($op);
4603     $flags = join '', sort split //, $flags;
4604     $flags = $matchwords{$flags} if $matchwords{$flags};
4605     if ($pmflags & PMf_ONCE) { # only one kind of delimiter works here
4606         $re =~ s/\?/\\?/g;
4607         $re = "?$re?";
4608     } elsif ($quote) {
4609         $re = single_delim($name, $delim, $re);
4610     }
4611     $re = $re . $flags if $quote;
4612     if ($binop) {
4613         return
4614          $self->maybe_parens(
4615           $rhs_bound_to_defsv
4616            ? "$var =~ (\$_ =~ $re)"
4617            : "$var =~ $re",
4618           $cx, 20
4619          );
4620     } else {
4621         return $re;
4622     }
4623 }
4624
4625 sub pp_match { matchop(@_, "m", "/") }
4626 sub pp_pushre { matchop(@_, "m", "/") }
4627 sub pp_qr { matchop(@_, "qr", "") }
4628
4629 sub pp_runcv { unop(@_, "__SUB__"); }
4630
4631 sub pp_split {
4632     my $self = shift;
4633     my($op, $cx) = @_;
4634     my($kid, @exprs, $ary, $expr);
4635     $kid = $op->first;
4636
4637     # For our kid (an OP_PUSHRE), pmreplroot is never actually the
4638     # root of a replacement; it's either empty, or abused to point to
4639     # the GV for an array we split into (an optimization to save
4640     # assignment overhead). Depending on whether we're using ithreads,
4641     # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
4642     # figures out for us which it is.
4643     my $replroot = $kid->pmreplroot;
4644     my $gv = 0;
4645     if (ref($replroot) eq "B::GV") {
4646         $gv = $replroot;
4647     } elsif (!ref($replroot) and $replroot > 0) {
4648         $gv = $self->padval($replroot);
4649     }
4650     $ary = $self->stash_variable('@', $self->gv_name($gv), $cx) if $gv;
4651
4652     for (; !null($kid); $kid = $kid->sibling) {
4653         push @exprs, $self->deparse($kid, 6);
4654     }
4655
4656     # handle special case of split(), and split(' ') that compiles to /\s+/
4657     # Under 5.10, the reflags may be undef if the split regexp isn't a constant
4658     $kid = $op->first;
4659     if ( $kid->flags & OPf_SPECIAL
4660          and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
4661               : ($kid->reflags || 0) & RXf_SKIPWHITE() ) ) {
4662         $exprs[0] = "' '";
4663     }
4664
4665     $expr = "split(" . join(", ", @exprs) . ")";
4666     if ($ary) {
4667         return $self->maybe_parens("$ary = $expr", $cx, 7);
4668     } else {
4669         return $expr;
4670     }
4671 }
4672
4673 # oxime -- any of various compounds obtained chiefly by the action of
4674 # hydroxylamine on aldehydes and ketones and characterized by the
4675 # bivalent grouping C=NOH [Webster's Tenth]
4676
4677 my %substwords;
4678 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
4679     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
4680     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
4681     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi', 'rogue',
4682     'sir', 'rise', 'smore', 'more', 'seer', 'rome', 'gore', 'grim', 'grime',
4683     'or', 'rose', 'rosie');
4684
4685 sub pp_subst {
4686     my $self = shift;
4687     my($op, $cx) = @_;
4688     my $kid = $op->first;
4689     my($binop, $var, $re, $repl) = ("", "", "", "");
4690     if ($op->flags & OPf_STACKED) {
4691         $binop = 1;
4692         $var = $self->deparse($kid, 20);
4693         $kid = $kid->sibling;
4694     }
4695     my $flags = "";
4696     my $pmflags = $op->pmflags;
4697     if (null($op->pmreplroot)) {
4698         $repl = $self->dq($kid);
4699         $kid = $kid->sibling;
4700     } else {
4701         $repl = $op->pmreplroot->first; # skip substcont
4702         while ($repl->name eq "entereval") {
4703             $repl = $repl->first;
4704             $flags .= "e";
4705         }
4706         if ($pmflags & PMf_EVAL) {
4707             $repl = $self->deparse($repl->first, 0);
4708         } else {
4709             $repl = $self->dq($repl);
4710         }
4711     }
4712     my $extended = ($pmflags & PMf_EXTENDED);
4713     if (null $kid) {
4714         my $unbacked = re_unback($op->precomp);
4715         if ($extended) {
4716             $re = re_uninterp_extended(escape_extended_re($unbacked));
4717         }
4718         else {
4719             $re = re_uninterp(escape_str($unbacked));
4720         }
4721     } else {
4722         ($re) = $self->regcomp($kid, 1, $extended);
4723     }
4724     $flags .= "r" if $pmflags & PMf_NONDESTRUCT;
4725     $flags .= "e" if $pmflags & PMf_EVAL;
4726     $flags .= $self->re_flags($op);
4727     $flags = join '', sort split //, $flags;
4728     $flags = $substwords{$flags} if $substwords{$flags};
4729     if ($binop) {
4730         return $self->maybe_parens("$var =~ s"
4731                                    . double_delim($re, $repl) . $flags,
4732                                    $cx, 20);
4733     } else {
4734         return "s". double_delim($re, $repl) . $flags;
4735     }
4736 }
4737
4738 1;
4739 __END__
4740
4741 =head1 NAME
4742
4743 B::Deparse - Perl compiler backend to produce perl code
4744
4745 =head1 SYNOPSIS
4746
4747 B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
4748         [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
4749
4750 =head1 DESCRIPTION
4751
4752 B::Deparse is a backend module for the Perl compiler that generates
4753 perl source code, based on the internal compiled structure that perl
4754 itself creates after parsing a program.  The output of B::Deparse won't
4755 be exactly the same as the original source, since perl doesn't keep
4756 track of comments or whitespace, and there isn't a one-to-one
4757 correspondence between perl's syntactical constructions and their
4758 compiled form, but it will often be close.  When you use the B<-p>
4759 option, the output also includes parentheses even when they are not
4760 required by precedence, which can make it easy to see if perl is
4761 parsing your expressions the way you intended.
4762
4763 While B::Deparse goes to some lengths to try to figure out what your
4764 original program was doing, some parts of the language can still trip
4765 it up; it still fails even on some parts of Perl's own test suite.  If
4766 you encounter a failure other than the most common ones described in
4767 the BUGS section below, you can help contribute to B::Deparse's
4768 ongoing development by submitting a bug report with a small
4769 example.
4770
4771 =head1 OPTIONS
4772
4773 As with all compiler backend options, these must follow directly after
4774 the '-MO=Deparse', separated by a comma but not any white space.
4775
4776 =over 4
4777
4778 =item B<-d>
4779
4780 Output data values (when they appear as constants) using Data::Dumper.
4781 Without this option, B::Deparse will use some simple routines of its
4782 own for the same purpose.  Currently, Data::Dumper is better for some
4783 kinds of data (such as complex structures with sharing and
4784 self-reference) while the built-in routines are better for others
4785 (such as odd floating-point values).
4786
4787 =item B<-f>I<FILE>
4788
4789 Normally, B::Deparse deparses the main code of a program, and all the subs
4790 defined in the same file.  To include subs defined in
4791 other files, pass the B<-f> option with the filename.
4792 You can pass the B<-f> option several times, to
4793 include more than one secondary file.  (Most of the time you don't want to
4794 use it at all.)  You can also use this option to include subs which are
4795 defined in the scope of a B<#line> directive with two parameters.
4796
4797 =item B<-l>
4798
4799 Add '#line' declarations to the output based on the line and file
4800 locations of the original code.
4801
4802 =item B<-p>
4803
4804 Print extra parentheses.  Without this option, B::Deparse includes
4805 parentheses in its output only when they are needed, based on the
4806 structure of your program.  With B<-p>, it uses parentheses (almost)
4807 whenever they would be legal.  This can be useful if you are used to
4808 LISP, or if you want to see how perl parses your input.  If you say
4809
4810     if ($var & 0x7f == 65) {print "Gimme an A!"}
4811     print ($which ? $a : $b), "\n";
4812     $name = $ENV{USER} or "Bob";
4813
4814 C<B::Deparse,-p> will print
4815
4816     if (($var & 0)) {
4817         print('Gimme an A!')
4818     };
4819     (print(($which ? $a : $b)), '???');
4820     (($name = $ENV{'USER'}) or '???')
4821
4822 which probably isn't what you intended (the C<'???'> is a sign that
4823 perl optimized away a constant value).
4824
4825 =item B<-P>
4826
4827 Disable prototype checking.  With this option, all function calls are
4828 deparsed as if no prototype was defined for them.  In other words,
4829
4830     perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
4831
4832 will print
4833
4834     sub foo (\@) {
4835         1;
4836     }
4837     &foo(\@x);
4838
4839 making clear how the parameters are actually passed to C<foo>.
4840
4841 =item B<-q>
4842
4843 Expand double-quoted strings into the corresponding combinations of
4844 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join.  For
4845 instance, print
4846
4847     print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
4848
4849 as
4850
4851     print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
4852           . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
4853
4854 Note that the expanded form represents the way perl handles such
4855 constructions internally -- this option actually turns off the reverse
4856 translation that B::Deparse usually does.  On the other hand, note that
4857 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
4858 of $y into a string before doing the assignment.
4859
4860 =item B<-s>I<LETTERS>
4861
4862 Tweak the style of B::Deparse's output.  The letters should follow
4863 directly after the 's', with no space or punctuation.  The following
4864 options are available:
4865
4866 =over 4
4867
4868 =item B<C>
4869
4870 Cuddle C<elsif>, C<else>, and C<continue> blocks.  For example, print
4871
4872     if (...) {
4873          ...
4874     } else {
4875          ...
4876     }
4877
4878 instead of
4879
4880     if (...) {
4881          ...
4882     }
4883     else {
4884          ...
4885     }
4886
4887 The default is not to cuddle.
4888
4889 =item B<i>I<NUMBER>
4890
4891 Indent lines by multiples of I<NUMBER> columns.  The default is 4 columns.
4892
4893 =item B<T>
4894
4895 Use tabs for each 8 columns of indent.  The default is to use only spaces.
4896 For instance, if the style options are B<-si4T>, a line that's indented
4897 3 times will be preceded by one tab and four spaces; if the options were
4898 B<-si8T>, the same line would be preceded by three tabs.
4899
4900 =item B<v>I<STRING>B<.>
4901
4902 Print I<STRING> for the value of a constant that can't be determined
4903 because it was optimized away (mnemonic: this happens when a constant
4904 is used in B<v>oid context).  The end of the string is marked by a period.
4905 The string should be a valid perl expression, generally a constant.
4906 Note that unless it's a number, it probably needs to be quoted, and on
4907 a command line quotes need to be protected from the shell.  Some
4908 conventional values include 0, 1, 42, '', 'foo', and
4909 'Useless use of constant omitted' (which may need to be
4910 B<-sv"'Useless use of constant omitted'.">
4911 or something similar depending on your shell).  The default is '???'.
4912 If you're using B::Deparse on a module or other file that's require'd,
4913 you shouldn't use a value that evaluates to false, since the customary
4914 true constant at the end of a module will be in void context when the
4915 file is compiled as a main program.
4916
4917 =back
4918
4919 =item B<-x>I<LEVEL>
4920
4921 Expand conventional syntax constructions into equivalent ones that expose
4922 their internal operation.  I<LEVEL> should be a digit, with higher values
4923 meaning more expansion.  As with B<-q>, this actually involves turning off
4924 special cases in B::Deparse's normal operations.
4925
4926 If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
4927 while loops with continue blocks; for instance
4928
4929     for ($i = 0; $i < 10; ++$i) {
4930         print $i;
4931     }
4932
4933 turns into
4934
4935     $i = 0;
4936     while ($i < 10) {
4937         print $i;
4938     } continue {
4939         ++$i
4940     }
4941
4942 Note that in a few cases this translation can't be perfectly carried back
4943 into the source code -- if the loop's initializer declares a my variable,
4944 for instance, it won't have the correct scope outside of the loop.
4945
4946 If I<LEVEL> is at least 5, C<use> declarations will be translated into
4947 C<BEGIN> blocks containing calls to C<require> and C<import>; for
4948 instance,
4949
4950     use strict 'refs';
4951
4952 turns into
4953
4954     sub BEGIN {
4955         require strict;
4956         do {
4957             'strict'->import('refs')
4958         };
4959     }
4960
4961 If I<LEVEL> is at least 7, C<if> statements will be translated into
4962 equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
4963
4964     print 'hi' if $nice;
4965     if ($nice) {
4966         print 'hi';
4967     }
4968     if ($nice) {
4969         print 'hi';
4970     } else {
4971         print 'bye';
4972     }
4973
4974 turns into
4975
4976     $nice and print 'hi';
4977     $nice and do { print 'hi' };
4978     $nice ? do { print 'hi' } : do { print 'bye' };
4979
4980 Long sequences of elsifs will turn into nested ternary operators, which
4981 B::Deparse doesn't know how to indent nicely.
4982
4983 =back
4984
4985 =head1 USING B::Deparse AS A MODULE
4986
4987 =head2 Synopsis
4988
4989     use B::Deparse;
4990     $deparse = B::Deparse->new("-p", "-sC");
4991     $body = $deparse->coderef2text(\&func);
4992     eval "sub func $body"; # the inverse operation
4993
4994 =head2 Description
4995
4996 B::Deparse can also be used on a sub-by-sub basis from other perl
4997 programs.
4998
4999 =head2 new
5000
5001     $deparse = B::Deparse->new(OPTIONS)
5002
5003 Create an object to store the state of a deparsing operation and any
5004 options.  The options are the same as those that can be given on the
5005 command line (see L</OPTIONS>); options that are separated by commas
5006 after B<-MO=Deparse> should be given as separate strings.
5007
5008 =head2 ambient_pragmas
5009
5010     $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
5011
5012 The compilation of a subroutine can be affected by a few compiler
5013 directives, B<pragmas>.  These are:
5014
5015 =over 4
5016
5017 =item *
5018
5019 use strict;
5020
5021 =item *
5022
5023 use warnings;
5024
5025 =item *
5026
5027 Assigning to the special variable $[
5028
5029 =item *
5030
5031 use integer;
5032
5033 =item *
5034
5035 use bytes;
5036
5037 =item *
5038
5039 use utf8;
5040
5041 =item *
5042
5043 use re;
5044
5045 =back
5046
5047 Ordinarily, if you use B::Deparse on a subroutine which has
5048 been compiled in the presence of one or more of these pragmas,
5049 the output will include statements to turn on the appropriate
5050 directives.  So if you then compile the code returned by coderef2text,
5051 it will behave the same way as the subroutine which you deparsed.
5052
5053 However, you may know that you intend to use the results in a
5054 particular context, where some pragmas are already in scope.  In
5055 this case, you use the B<ambient_pragmas> method to describe the
5056 assumptions you wish to make.
5057
5058 Not all of the options currently have any useful effect.  See
5059 L</BUGS> for more details.
5060
5061 The parameters it accepts are:
5062
5063 =over 4
5064
5065 =item strict
5066
5067 Takes a string, possibly containing several values separated
5068 by whitespace.  The special values "all" and "none" mean what you'd
5069 expect.
5070
5071     $deparse->ambient_pragmas(strict => 'subs refs');
5072
5073 =item $[
5074
5075 Takes a number, the value of the array base $[.
5076 Cannot be non-zero on Perl 5.15.3 or later.
5077
5078 =item bytes
5079
5080 =item utf8
5081
5082 =item integer
5083
5084 If the value is true, then the appropriate pragma is assumed to
5085 be in the ambient scope, otherwise not.
5086
5087 =item re
5088
5089 Takes a string, possibly containing a whitespace-separated list of
5090 values.  The values "all" and "none" are special.  It's also permissible
5091 to pass an array reference here.
5092
5093     $deparser->ambient_pragmas(re => 'eval');
5094
5095
5096 =item warnings
5097
5098 Takes a string, possibly containing a whitespace-separated list of
5099 values.  The values "all" and "none" are special, again.  It's also
5100 permissible to pass an array reference here.
5101
5102     $deparser->ambient_pragmas(warnings => [qw[void io]]);
5103
5104 If one of the values is the string "FATAL", then all the warnings
5105 in that list will be considered fatal, just as with the B<warnings>
5106 pragma itself.  Should you need to specify that some warnings are
5107 fatal, and others are merely enabled, you can pass the B<warnings>
5108 parameter twice:
5109
5110     $deparser->ambient_pragmas(
5111         warnings => 'all',
5112         warnings => [FATAL => qw/void io/],
5113     );
5114
5115 See L<perllexwarn> for more information about lexical warnings.
5116
5117 =item hint_bits
5118
5119 =item warning_bits
5120
5121 These two parameters are used to specify the ambient pragmas in
5122 the format used by the special variables $^H and ${^WARNING_BITS}.
5123
5124 They exist principally so that you can write code like:
5125
5126     { my ($hint_bits, $warning_bits);
5127     BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
5128     $deparser->ambient_pragmas (
5129         hint_bits    => $hint_bits,
5130         warning_bits => $warning_bits,
5131         '$['         => 0 + $[
5132     ); }
5133
5134 which specifies that the ambient pragmas are exactly those which
5135 are in scope at the point of calling.
5136
5137 =item %^H
5138
5139 This parameter is used to specify the ambient pragmas which are
5140 stored in the special hash %^H.
5141
5142 =back
5143
5144 =head2 coderef2text
5145
5146     $body = $deparse->coderef2text(\&func)
5147     $body = $deparse->coderef2text(sub ($$) { ... })
5148
5149 Return source code for the body of a subroutine (a block, optionally
5150 preceded by a prototype in parens), given a reference to the
5151 sub.  Because a subroutine can have no names, or more than one name,
5152 this method doesn't return a complete subroutine definition -- if you
5153 want to eval the result, you should prepend "sub subname ", or "sub "
5154 for an anonymous function constructor.  Unless the sub was defined in
5155 the main:: package, the code will include a package declaration.
5156
5157 =head1 BUGS
5158
5159 =over 4
5160
5161 =item *
5162
5163 The only pragmas to be completely supported are: C<use warnings>,
5164 C<use strict>, C<use bytes>, C<use integer>
5165 and C<use feature>.  (C<$[>, which
5166 behaves like a pragma, is also supported.)
5167
5168 Excepting those listed above, we're currently unable to guarantee that
5169 B::Deparse will produce a pragma at the correct point in the program.
5170 (Specifically, pragmas at the beginning of a block often appear right
5171 before the start of the block instead.)
5172 Since the effects of pragmas are often lexically scoped, this can mean
5173 that the pragma holds sway over a different portion of the program
5174 than in the input file.
5175
5176 =item *
5177
5178 In fact, the above is a specific instance of a more general problem:
5179 we can't guarantee to produce BEGIN blocks or C<use> declarations in
5180 exactly the right place.  So if you use a module which affects compilation
5181 (such as by over-riding keywords, overloading constants or whatever)
5182 then the output code might not work as intended.
5183
5184 This is the most serious outstanding problem, and will require some help
5185 from the Perl core to fix.
5186
5187 =item *
5188
5189 Some constants don't print correctly either with or without B<-d>.
5190 For instance, neither B::Deparse nor Data::Dumper know how to print
5191 dual-valued scalars correctly, as in:
5192
5193     use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
5194
5195     use constant H => { "#" => 1 }; H->{"#"};
5196
5197 =item *
5198
5199 An input file that uses source filtering probably won't be deparsed into
5200 runnable code, because it will still include the B<use> declaration
5201 for the source filtering module, even though the code that is
5202 produced is already ordinary Perl which shouldn't be filtered again.
5203
5204 =item *
5205
5206 Optimised away statements are rendered as
5207 '???'.  This includes statements that
5208 have a compile-time side-effect, such as the obscure
5209
5210     my $x if 0;
5211
5212 which is not, consequently, deparsed correctly.
5213
5214     foreach my $i (@_) { 0 }
5215   =>
5216     foreach my $i (@_) { '???' }
5217
5218 =item *
5219
5220 Lexical (my) variables declared in scopes external to a subroutine
5221 appear in code2ref output text as package variables.  This is a tricky
5222 problem, as perl has no native facility for referring to a lexical variable
5223 defined within a different scope, although L<PadWalker> is a good start.
5224
5225 =item *
5226
5227 There are probably many more bugs on non-ASCII platforms (EBCDIC).
5228
5229 =back
5230
5231 =head1 AUTHOR
5232
5233 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version
5234 by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from
5235 Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
5236 Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael
5237 Garcia-Suarez.
5238
5239 =cut