lib/B/Deparse.pm

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