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