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.37';
  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                 PMf_CHARSET PMf_KEEPCOPY PMf_NOCAPTURE 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 { B->import($_) };
  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         and $op->flags & OPf_SPECIAL
2647         and $self->deparse($kid, 1) eq 'ARGV')
2648     {
2649         return '<<>>';
2650     }
2651     return $self->unop($op, $cx, "readline");
2652 }
2653
2654 sub pp_rcatline {
2655     my $self = shift;
2656     my($op) = @_;
2657     return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
2658 }
2659
2660 # Unary operators that can occur as pseudo-listops inside double quotes
2661 sub dq_unop {
2662     my $self = shift;
2663     my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
2664     my $kid;
2665     if ($op->flags & OPf_KIDS) {
2666        $kid = $op->first;
2667        # If there's more than one kid, the first is an ex-pushmark.
2668        $kid = $kid->sibling if not null $kid->sibling;
2669        return $self->maybe_parens_unop($name, $kid, $cx);
2670     } else {
2671        return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");
2672     }
2673 }
2674
2675 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
2676 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
2677 sub pp_uc { dq_unop(@_, "uc") }
2678 sub pp_lc { dq_unop(@_, "lc") }
2679 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
2680 sub pp_fc { dq_unop(@_, "fc") }
2681
2682 sub loopex {
2683     my $self = shift;
2684     my ($op, $cx, $name) = @_;
2685     if (class($op) eq "PVOP") {
2686         $name .= " " . $op->pv;
2687     } elsif (class($op) eq "OP") {
2688         # no-op
2689     } elsif (class($op) eq "UNOP") {
2690         (my $kid = $self->deparse($op->first, 7)) =~ s/^\cS//;
2691         # last foo() is a syntax error.
2692         $kid =~ /^(?!\d)\w/ and $kid = "($kid)";
2693         $name .= " $kid";
2694     }
2695     return $self->maybe_parens($name, $cx, 7);
2696 }
2697
2698 sub pp_last { loopex(@_, "last") }
2699 sub pp_next { loopex(@_, "next") }
2700 sub pp_redo { loopex(@_, "redo") }
2701 sub pp_goto { loopex(@_, "goto") }
2702 sub pp_dump { loopex(@_, "CORE::dump") }
2703
2704 sub ftst {
2705     my $self = shift;
2706     my($op, $cx, $name) = @_;
2707     if (class($op) eq "UNOP") {
2708         # Genuine '-X' filetests are exempt from the LLAFR, but not
2709         # l?stat()
2710         if ($name =~ /^-/) {
2711             (my $kid = $self->deparse($op->first, 16)) =~ s/^\cS//;
2712             return $self->maybe_parens("$name $kid", $cx, 16);
2713         }
2714         return $self->maybe_parens_unop($name, $op->first, $cx);
2715     } elsif (class($op) =~ /^(SV|PAD)OP$/) {
2716         return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
2717     } else { # I don't think baseop filetests ever survive ck_ftst, but...
2718         return $name;
2719     }
2720 }
2721
2722 sub pp_lstat    { ftst(@_, "lstat") }
2723 sub pp_stat     { ftst(@_, "stat") }
2724 sub pp_ftrread  { ftst(@_, "-R") }
2725 sub pp_ftrwrite { ftst(@_, "-W") }
2726 sub pp_ftrexec  { ftst(@_, "-X") }
2727 sub pp_fteread  { ftst(@_, "-r") }
2728 sub pp_ftewrite { ftst(@_, "-w") }
2729 sub pp_fteexec  { ftst(@_, "-x") }
2730 sub pp_ftis     { ftst(@_, "-e") }
2731 sub pp_fteowned { ftst(@_, "-O") }
2732 sub pp_ftrowned { ftst(@_, "-o") }
2733 sub pp_ftzero   { ftst(@_, "-z") }
2734 sub pp_ftsize   { ftst(@_, "-s") }
2735 sub pp_ftmtime  { ftst(@_, "-M") }
2736 sub pp_ftatime  { ftst(@_, "-A") }
2737 sub pp_ftctime  { ftst(@_, "-C") }
2738 sub pp_ftsock   { ftst(@_, "-S") }
2739 sub pp_ftchr    { ftst(@_, "-c") }
2740 sub pp_ftblk    { ftst(@_, "-b") }
2741 sub pp_ftfile   { ftst(@_, "-f") }
2742 sub pp_ftdir    { ftst(@_, "-d") }
2743 sub pp_ftpipe   { ftst(@_, "-p") }
2744 sub pp_ftlink   { ftst(@_, "-l") }
2745 sub pp_ftsuid   { ftst(@_, "-u") }
2746 sub pp_ftsgid   { ftst(@_, "-g") }
2747 sub pp_ftsvtx   { ftst(@_, "-k") }
2748 sub pp_fttty    { ftst(@_, "-t") }
2749 sub pp_fttext   { ftst(@_, "-T") }
2750 sub pp_ftbinary { ftst(@_, "-B") }
2751
2752 sub SWAP_CHILDREN () { 1 }
2753 sub ASSIGN () { 2 } # has OP= variant
2754 sub LIST_CONTEXT () { 4 } # Assignment is in list context
2755
2756 my(%left, %right);
2757
2758 sub assoc_class {
2759     my $op = shift;
2760     my $name = $op->name;
2761     if ($name eq "concat" and $op->first->name eq "concat") {
2762         # avoid spurious '=' -- see comment in pp_concat
2763         return "concat";
2764     }
2765     if ($name eq "null" and class($op) eq "UNOP"
2766         and $op->first->name =~ /^(and|x?or)$/
2767         and null $op->first->sibling)
2768     {
2769         # Like all conditional constructs, OP_ANDs and OP_ORs are topped
2770         # with a null that's used as the common end point of the two
2771         # flows of control. For precedence purposes, ignore it.
2772         # (COND_EXPRs have these too, but we don't bother with
2773         # their associativity).
2774         return assoc_class($op->first);
2775     }
2776     return $name . ($op->flags & OPf_STACKED ? "=" : "");
2777 }
2778
2779 # Left associative operators, like '+', for which
2780 # $a + $b + $c is equivalent to ($a + $b) + $c
2781
2782 BEGIN {
2783     %left = ('multiply' => 19, 'i_multiply' => 19,
2784              'divide' => 19, 'i_divide' => 19,
2785              'modulo' => 19, 'i_modulo' => 19,
2786              'repeat' => 19,
2787              'add' => 18, 'i_add' => 18,
2788              'subtract' => 18, 'i_subtract' => 18,
2789              'concat' => 18,
2790              'left_shift' => 17, 'right_shift' => 17,
2791              'bit_and' => 13, 'nbit_and' => 13, 'sbit_and' => 13,
2792              'bit_or' => 12, 'bit_xor' => 12,
2793              'sbit_or' => 12, 'sbit_xor' => 12,
2794              'nbit_or' => 12, 'nbit_xor' => 12,
2795              'and' => 3,
2796              'or' => 2, 'xor' => 2,
2797             );
2798 }
2799
2800 sub deparse_binop_left {
2801     my $self = shift;
2802     my($op, $left, $prec) = @_;
2803     if ($left{assoc_class($op)} && $left{assoc_class($left)}
2804         and $left{assoc_class($op)} == $left{assoc_class($left)})
2805     {
2806         return $self->deparse($left, $prec - .00001);
2807     } else {
2808         return $self->deparse($left, $prec);
2809     }
2810 }
2811
2812 # Right associative operators, like '=', for which
2813 # $a = $b = $c is equivalent to $a = ($b = $c)
2814
2815 BEGIN {
2816     %right = ('pow' => 22,
2817               'sassign=' => 7, 'aassign=' => 7,
2818               'multiply=' => 7, 'i_multiply=' => 7,
2819               'divide=' => 7, 'i_divide=' => 7,
2820               'modulo=' => 7, 'i_modulo=' => 7,
2821               'repeat=' => 7, 'refassign' => 7, 'refassign=' => 7,
2822               'add=' => 7, 'i_add=' => 7,
2823               'subtract=' => 7, 'i_subtract=' => 7,
2824               'concat=' => 7,
2825               'left_shift=' => 7, 'right_shift=' => 7,
2826               'bit_and=' => 7, 'sbit_and=' => 7, 'nbit_and=' => 7,
2827               'nbit_or=' => 7, 'nbit_xor=' => 7,
2828               'sbit_or=' => 7, 'sbit_xor=' => 7,
2829               'andassign' => 7,
2830               'orassign' => 7,
2831              );
2832 }
2833
2834 sub deparse_binop_right {
2835     my $self = shift;
2836     my($op, $right, $prec) = @_;
2837     if ($right{assoc_class($op)} && $right{assoc_class($right)}
2838         and $right{assoc_class($op)} == $right{assoc_class($right)})
2839     {
2840         return $self->deparse($right, $prec - .00001);
2841     } else {
2842         return $self->deparse($right, $prec);
2843     }
2844 }
2845
2846 sub binop {
2847     my $self = shift;
2848     my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
2849     my $left = $op->first;
2850     my $right = $op->last;
2851     my $eq = "";
2852     if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
2853         $eq = "=";
2854         $prec = 7;
2855     }
2856     if ($flags & SWAP_CHILDREN) {
2857         ($left, $right) = ($right, $left);
2858     }
2859     my $leftop = $left;
2860     $left = $self->deparse_binop_left($op, $left, $prec);
2861     $left = "($left)" if $flags & LIST_CONTEXT
2862                      and    $left !~ /^(my|our|local|)[\@\(]/
2863                          || do {
2864                                 # Parenthesize if the left argument is a
2865                                 # lone repeat op.
2866                                 my $left = $leftop->first->sibling;
2867                                 $left->name eq 'repeat'
2868                                     && null($left->sibling);
2869                             };
2870     $right = $self->deparse_binop_right($op, $right, $prec);
2871     return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
2872 }
2873
2874 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2875 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2876 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18,  ASSIGN) }
2877 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2878 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2879 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2880 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2881 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
2882 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2883 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2884 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
2885
2886 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
2887 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
2888 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
2889 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
2890 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
2891 *pp_nbit_and = *pp_bit_and;
2892 *pp_nbit_or  = *pp_bit_or;
2893 *pp_nbit_xor = *pp_bit_xor;
2894 sub pp_sbit_and { maybe_targmy(@_, \&binop, "&.", 13, ASSIGN) }
2895 sub pp_sbit_or { maybe_targmy(@_, \&binop, "|.", 12, ASSIGN) }
2896 sub pp_sbit_xor { maybe_targmy(@_, \&binop, "^.", 12, ASSIGN) }
2897
2898 sub pp_eq { binop(@_, "==", 14) }
2899 sub pp_ne { binop(@_, "!=", 14) }
2900 sub pp_lt { binop(@_, "<", 15) }
2901 sub pp_gt { binop(@_, ">", 15) }
2902 sub pp_ge { binop(@_, ">=", 15) }
2903 sub pp_le { binop(@_, "<=", 15) }
2904 sub pp_ncmp { binop(@_, "<=>", 14) }
2905 sub pp_i_eq { binop(@_, "==", 14) }
2906 sub pp_i_ne { binop(@_, "!=", 14) }
2907 sub pp_i_lt { binop(@_, "<", 15) }
2908 sub pp_i_gt { binop(@_, ">", 15) }
2909 sub pp_i_ge { binop(@_, ">=", 15) }
2910 sub pp_i_le { binop(@_, "<=", 15) }
2911 sub pp_i_ncmp { maybe_targmy(@_, \&binop, "<=>", 14) }
2912
2913 sub pp_seq { binop(@_, "eq", 14) }
2914 sub pp_sne { binop(@_, "ne", 14) }
2915 sub pp_slt { binop(@_, "lt", 15) }
2916 sub pp_sgt { binop(@_, "gt", 15) }
2917 sub pp_sge { binop(@_, "ge", 15) }
2918 sub pp_sle { binop(@_, "le", 15) }
2919 sub pp_scmp { maybe_targmy(@_, \&binop, "cmp", 14) }
2920
2921 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
2922 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
2923
2924 sub pp_smartmatch {
2925     my ($self, $op, $cx) = @_;
2926     if ($op->flags & OPf_SPECIAL) {
2927         return $self->deparse($op->last, $cx);
2928     }
2929     else {
2930         binop(@_, "~~", 14);
2931     }
2932 }
2933
2934 # '.' is special because concats-of-concats are optimized to save copying
2935 # by making all but the first concat stacked. The effect is as if the
2936 # programmer had written '($a . $b) .= $c', except legal.
2937 sub pp_concat { maybe_targmy(@_, \&real_concat) }
2938 sub real_concat {
2939     my $self = shift;
2940     my($op, $cx) = @_;
2941     my $left = $op->first;
2942     my $right = $op->last;
2943     my $eq = "";
2944     my $prec = 18;
2945     if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
2946         $eq = "=";
2947         $prec = 7;
2948     }
2949     $left = $self->deparse_binop_left($op, $left, $prec);
2950     $right = $self->deparse_binop_right($op, $right, $prec);
2951     return $self->maybe_parens("$left .$eq $right", $cx, $prec);
2952 }
2953
2954 sub pp_repeat { maybe_targmy(@_, \&repeat) }
2955
2956 # 'x' is weird when the left arg is a list
2957 sub repeat {
2958     my $self = shift;
2959     my($op, $cx) = @_;
2960     my $left = $op->first;
2961     my $right = $op->last;
2962     my $eq = "";
2963     my $prec = 19;
2964     if ($op->flags & OPf_STACKED) {
2965         $eq = "=";
2966         $prec = 7;
2967     }
2968     if (null($right)) { # list repeat; count is inside left-side ex-list
2969                         # in 5.21.5 and earlier
2970         my $kid = $left->first->sibling; # skip pushmark
2971         my @exprs;
2972         for (; !null($kid->sibling); $kid = $kid->sibling) {
2973             push @exprs, $self->deparse($kid, 6);
2974         }
2975         $right = $kid;
2976         $left = "(" . join(", ", @exprs). ")";
2977     } else {
2978         my $dolist = $op->private & OPpREPEAT_DOLIST;
2979         $left = $self->deparse_binop_left($op, $left, $dolist ? 1 : $prec);
2980         if ($dolist) {
2981             $left = "($left)";
2982         }
2983     }
2984     $right = $self->deparse_binop_right($op, $right, $prec);
2985     return $self->maybe_parens("$left x$eq $right", $cx, $prec);
2986 }
2987
2988 sub range {
2989     my $self = shift;
2990     my ($op, $cx, $type) = @_;
2991     my $left = $op->first;
2992     my $right = $left->sibling;
2993     $left = $self->deparse($left, 9);
2994     $right = $self->deparse($right, 9);
2995     return $self->maybe_parens("$left $type $right", $cx, 9);
2996 }
2997
2998 sub pp_flop {
2999     my $self = shift;
3000     my($op, $cx) = @_;
3001     my $flip = $op->first;
3002     my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
3003     return $self->range($flip->first, $cx, $type);
3004 }
3005
3006 # one-line while/until is handled in pp_leave
3007
3008 sub logop {
3009     my $self = shift;
3010     my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
3011     my $left = $op->first;
3012     my $right = $op->first->sibling;
3013     $blockname &&= $self->keyword($blockname);
3014     if ($cx < 1 and is_scope($right) and $blockname
3015         and $self->{'expand'} < 7)
3016     { # if ($a) {$b}
3017         $left = $self->deparse($left, 1);
3018         $right = $self->deparse($right, 0);
3019         return "$blockname ($left) {\n\t$right\n\b}\cK";
3020     } elsif ($cx < 1 and $blockname and not $self->{'parens'}
3021              and $self->{'expand'} < 7) { # $b if $a
3022         $right = $self->deparse($right, 1);
3023         $left = $self->deparse($left, 1);
3024         return "$right $blockname $left";
3025     } elsif ($cx > $lowprec and $highop) { # $a && $b
3026         $left = $self->deparse_binop_left($op, $left, $highprec);
3027         $right = $self->deparse_binop_right($op, $right, $highprec);
3028         return $self->maybe_parens("$left $highop $right", $cx, $highprec);
3029     } else { # $a and $b
3030         $left = $self->deparse_binop_left($op, $left, $lowprec);
3031         $right = $self->deparse_binop_right($op, $right, $lowprec);
3032         return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
3033     }
3034 }
3035
3036 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
3037 sub pp_or  { logop(@_, "or",  2, "||", 10, "unless") }
3038 sub pp_dor { logop(@_, "//", 10) }
3039
3040 # xor is syntactically a logop, but it's really a binop (contrary to
3041 # old versions of opcode.pl). Syntax is what matters here.
3042 sub pp_xor { logop(@_, "xor", 2, "",   0,  "") }
3043
3044 sub logassignop {
3045     my $self = shift;
3046     my ($op, $cx, $opname) = @_;
3047     my $left = $op->first;
3048     my $right = $op->first->sibling->first; # skip sassign
3049     $left = $self->deparse($left, 7);
3050     $right = $self->deparse($right, 7);
3051     return $self->maybe_parens("$left $opname $right", $cx, 7);
3052 }
3053
3054 sub pp_andassign { logassignop(@_, "&&=") }
3055 sub pp_orassign  { logassignop(@_, "||=") }
3056 sub pp_dorassign { logassignop(@_, "//=") }
3057
3058 sub rv2gv_or_string {
3059     my($self,$op) = @_;
3060     if ($op->name eq "gv") { # could be open("open") or open("###")
3061         my($name,$quoted) =
3062             $self->stash_variable_name("", $self->gv_or_padgv($op));
3063         $quoted ? $name : "*$name";
3064     }
3065     else {
3066         $self->deparse($op, 6);
3067     }
3068 }
3069
3070 sub listop {
3071     my $self = shift;
3072     my($op, $cx, $name, $kid, $nollafr) = @_;
3073     my(@exprs);
3074     my $parens = ($cx >= 5) || $self->{'parens'};
3075     $kid ||= $op->first->sibling;
3076     # If there are no arguments, add final parentheses (or parenthesize the
3077     # whole thing if the llafr does not apply) to account for cases like
3078     # (return)+1 or setpgrp()+1.  When the llafr does not apply, we use a
3079     # precedence of 6 (< comma), as "return, 1" does not need parentheses.
3080     if (null $kid) {
3081         return $nollafr
3082                 ? $self->maybe_parens($self->keyword($name), $cx, 7)
3083                 : $self->keyword($name) . '()' x (7 < $cx);
3084     }
3085     my $first;
3086     my $fullname = $self->keyword($name);
3087     my $proto = prototype("CORE::$name");
3088     if (
3089          (     (defined $proto && $proto =~ /^;?\*/)
3090             || $name eq 'select' # select(F) doesn't have a proto
3091          )
3092          && $kid->name eq "rv2gv"
3093          && !($kid->private & OPpLVAL_INTRO)
3094     ) {
3095         $first = $self->rv2gv_or_string($kid->first);
3096     }
3097     else {
3098         $first = $self->deparse($kid, 6);
3099     }
3100     if ($name eq "chmod" && $first =~ /^\d+$/) {
3101         $first = sprintf("%#o", $first);
3102     }
3103     $first = "+$first"
3104         if not $parens and not $nollafr and substr($first, 0, 1) eq "(";
3105     push @exprs, $first;
3106     $kid = $kid->sibling;
3107     if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv"
3108          && !($kid->private & OPpLVAL_INTRO)) {
3109         push @exprs, $first = $self->rv2gv_or_string($kid->first);
3110         $kid = $kid->sibling;
3111     }
3112     for (; !null($kid); $kid = $kid->sibling) {
3113         push @exprs, $self->deparse($kid, 6);
3114     }
3115     if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) {
3116         return "$exprs[0] = $fullname"
3117                  . ($parens ? "($exprs[0])" : " $exprs[0]");
3118     }
3119
3120     if ($parens && $nollafr) {
3121         return "($fullname " . join(", ", @exprs) . ")";
3122     } elsif ($parens) {
3123         return "$fullname(" . join(", ", @exprs) . ")";
3124     } else {
3125         return "$fullname " . join(", ", @exprs);
3126     }
3127 }
3128
3129 sub pp_bless { listop(@_, "bless") }
3130 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
3131 sub pp_substr {
3132     my ($self,$op,$cx) = @_;
3133     if ($op->private & OPpSUBSTR_REPL_FIRST) {
3134         return
3135            listop($self, $op, 7, "substr", $op->first->sibling->sibling)
3136          . " = "
3137          . $self->deparse($op->first->sibling, 7);
3138     }
3139     maybe_local(@_, listop(@_, "substr"))
3140 }
3141 sub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) }
3142 sub pp_index { maybe_targmy(@_, \&listop, "index") }
3143 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
3144 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
3145 sub pp_formline { listop(@_, "formline") } # see also deparse_format
3146 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
3147 sub pp_unpack { listop(@_, "unpack") }
3148 sub pp_pack { listop(@_, "pack") }
3149 sub pp_join { maybe_targmy(@_, \&listop, "join") }
3150 sub pp_splice { listop(@_, "splice") }
3151 sub pp_push { maybe_targmy(@_, \&listop, "push") }
3152 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
3153 sub pp_reverse { listop(@_, "reverse") }
3154 sub pp_warn { listop(@_, "warn") }
3155 sub pp_die { listop(@_, "die") }
3156 sub pp_return { listop(@_, "return", undef, 1) } # llafr does not apply
3157 sub pp_open { listop(@_, "open") }
3158 sub pp_pipe_op { listop(@_, "pipe") }
3159 sub pp_tie { listop(@_, "tie") }
3160 sub pp_binmode { listop(@_, "binmode") }
3161 sub pp_dbmopen { listop(@_, "dbmopen") }
3162 sub pp_sselect { listop(@_, "select") }
3163 sub pp_select { listop(@_, "select") }
3164 sub pp_read { listop(@_, "read") }
3165 sub pp_sysopen { listop(@_, "sysopen") }
3166 sub pp_sysseek { listop(@_, "sysseek") }
3167 sub pp_sysread { listop(@_, "sysread") }
3168 sub pp_syswrite { listop(@_, "syswrite") }
3169 sub pp_send { listop(@_, "send") }
3170 sub pp_recv { listop(@_, "recv") }
3171 sub pp_seek { listop(@_, "seek") }
3172 sub pp_fcntl { listop(@_, "fcntl") }
3173 sub pp_ioctl { listop(@_, "ioctl") }
3174 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
3175 sub pp_socket { listop(@_, "socket") }
3176 sub pp_sockpair { listop(@_, "socketpair") }
3177 sub pp_bind { listop(@_, "bind") }
3178 sub pp_connect { listop(@_, "connect") }
3179 sub pp_listen { listop(@_, "listen") }
3180 sub pp_accept { listop(@_, "accept") }
3181 sub pp_shutdown { listop(@_, "shutdown") }
3182 sub pp_gsockopt { listop(@_, "getsockopt") }
3183 sub pp_ssockopt { listop(@_, "setsockopt") }
3184 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
3185 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
3186 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
3187 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
3188 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
3189 sub pp_link { maybe_targmy(@_, \&listop, "link") }
3190 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
3191 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
3192 sub pp_open_dir { listop(@_, "opendir") }
3193 sub pp_seekdir { listop(@_, "seekdir") }
3194 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
3195 sub pp_system { maybe_targmy(@_, \&indirop, "system") }
3196 sub pp_exec { maybe_targmy(@_, \&indirop, "exec") }
3197 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
3198 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
3199 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
3200 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
3201 sub pp_shmget { listop(@_, "shmget") }
3202 sub pp_shmctl { listop(@_, "shmctl") }
3203 sub pp_shmread { listop(@_, "shmread") }
3204 sub pp_shmwrite { listop(@_, "shmwrite") }
3205 sub pp_msgget { listop(@_, "msgget") }
3206 sub pp_msgctl { listop(@_, "msgctl") }
3207 sub pp_msgsnd { listop(@_, "msgsnd") }
3208 sub pp_msgrcv { listop(@_, "msgrcv") }
3209 sub pp_semget { listop(@_, "semget") }
3210 sub pp_semctl { listop(@_, "semctl") }
3211 sub pp_semop { listop(@_, "semop") }
3212 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
3213 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
3214 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
3215 sub pp_gsbyname { listop(@_, "getservbyname") }
3216 sub pp_gsbyport { listop(@_, "getservbyport") }
3217 sub pp_syscall { listop(@_, "syscall") }
3218
3219 sub pp_glob {
3220     my $self = shift;
3221     my($op, $cx) = @_;
3222     my $kid = $op->first->sibling;  # skip pushmark
3223     my $keyword =
3224         $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
3225     my $text = $self->deparse($kid);
3226     return $cx >= 5 || $self->{'parens'}
3227         ? "$keyword($text)"
3228         : "$keyword $text";
3229 }
3230
3231 # Truncate is special because OPf_SPECIAL makes a bareword first arg
3232 # be a filehandle. This could probably be better fixed in the core
3233 # by moving the GV lookup into ck_truc.
3234
3235 sub pp_truncate {
3236     my $self = shift;
3237     my($op, $cx) = @_;
3238     my(@exprs);
3239     my $parens = ($cx >= 5) || $self->{'parens'};
3240     my $kid = $op->first->sibling;
3241     my $fh;
3242     if ($op->flags & OPf_SPECIAL) {
3243         # $kid is an OP_CONST
3244         $fh = $self->const_sv($kid)->PV;
3245     } else {
3246         $fh = $self->deparse($kid, 6);
3247         $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
3248     }
3249     my $len = $self->deparse($kid->sibling, 6);
3250     my $name = $self->keyword('truncate');
3251     if ($parens) {
3252         return "$name($fh, $len)";
3253     } else {
3254         return "$name $fh, $len";
3255     }
3256 }
3257
3258 sub indirop {
3259     my $self = shift;
3260     my($op, $cx, $name) = @_;
3261     my($expr, @exprs);
3262     my $firstkid = my $kid = $op->first->sibling;
3263     my $indir = "";
3264     if ($op->flags & OPf_STACKED) {
3265         $indir = $kid;
3266         $indir = $indir->first; # skip rv2gv
3267         if (is_scope($indir)) {
3268             $indir = "{" . $self->deparse($indir, 0) . "}";
3269             $indir = "{;}" if $indir eq "{}";
3270         } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
3271             $indir = $self->const_sv($indir)->PV;
3272         } else {
3273             $indir = $self->deparse($indir, 24);
3274         }
3275         $indir = $indir . " ";
3276         $kid = $kid->sibling;
3277     }
3278     if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
3279         $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
3280                                                   : '{$a <=> $b} ';
3281     }
3282     elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
3283         $indir = '{$b cmp $a} ';
3284     }
3285     for (; !null($kid); $kid = $kid->sibling) {
3286         $expr = $self->deparse($kid, !$indir && $kid == $firstkid && $name eq "sort" && $firstkid->name eq "entersub" ? 16 : 6);
3287         push @exprs, $expr;
3288     }
3289     my $name2;
3290     if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
3291         $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort');
3292     }
3293     else { $name2 = $self->keyword($name) }
3294     if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
3295         return "$exprs[0] = $name2 $indir $exprs[0]";
3296     }
3297
3298     my $args = $indir . join(", ", @exprs);
3299     if ($indir ne "" && $name eq "sort") {
3300         # We don't want to say "sort(f 1, 2, 3)", since perl -w will
3301         # give bareword warnings in that case. Therefore if context
3302         # requires, we'll put parens around the outside "(sort f 1, 2,
3303         # 3)". Unfortunately, we'll currently think the parens are
3304         # necessary more often that they really are, because we don't
3305         # distinguish which side of an assignment we're on.
3306         if ($cx >= 5) {
3307             return "($name2 $args)";
3308         } else {
3309             return "$name2 $args";
3310         }
3311     } elsif (
3312         !$indir && $name eq "sort"
3313       && !null($op->first->sibling)
3314       && $op->first->sibling->name eq 'entersub'
3315     ) {
3316         # We cannot say sort foo(bar), as foo will be interpreted as a
3317         # comparison routine.  We have to say sort(...) in that case.
3318         return "$name2($args)";
3319     } else {
3320         return length $args
3321                 ? $self->maybe_parens_func($name2, $args, $cx, 5)
3322                 : $name2 . '()' x (7 < $cx);
3323     }
3324
3325 }
3326
3327 sub pp_prtf { indirop(@_, "printf") }
3328 sub pp_print { indirop(@_, "print") }
3329 sub pp_say  { indirop(@_, "say") }
3330 sub pp_sort { indirop(@_, "sort") }
3331
3332 sub mapop {
3333     my $self = shift;
3334     my($op, $cx, $name) = @_;
3335     my($expr, @exprs);
3336     my $kid = $op->first; # this is the (map|grep)start
3337     $kid = $kid->first->sibling; # skip a pushmark
3338     my $code = $kid->first; # skip a null
3339     if (is_scope $code) {
3340         $code = "{" . $self->deparse($code, 0) . "} ";
3341     } else {
3342         $code = $self->deparse($code, 24);
3343         $code .= ", " if !null($kid->sibling);
3344     }
3345     $kid = $kid->sibling;
3346     for (; !null($kid); $kid = $kid->sibling) {
3347         $expr = $self->deparse($kid, 6);
3348         push @exprs, $expr if defined $expr;
3349     }
3350     return $self->maybe_parens_func($self->keyword($name),
3351                                     $code . join(", ", @exprs), $cx, 5);
3352 }
3353
3354 sub pp_mapwhile { mapop(@_, "map") }
3355 sub pp_grepwhile { mapop(@_, "grep") }
3356 sub pp_mapstart { baseop(@_, "map") }
3357 sub pp_grepstart { baseop(@_, "grep") }
3358
3359 my %uses_intro;
3360 BEGIN {
3361     @uses_intro{
3362         eval { require B::Op_private }
3363           ? @{$B::Op_private::ops_using{OPpLVAL_INTRO}}
3364           : qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice
3365                hslice delete padsv padav padhv enteriter entersub padrange
3366                pushmark cond_expr refassign list)
3367     } = ();
3368     delete @uses_intro{qw( lvref lvrefslice lvavref entersub )};
3369 }
3370
3371 sub pp_list {
3372     my $self = shift;
3373     my($op, $cx) = @_;
3374     my($expr, @exprs);
3375     my $kid = $op->first->sibling; # skip pushmark
3376     return '' if class($kid) eq 'NULL';
3377     my $lop;
3378     my $local = "either"; # could be local(...), my(...), state(...) or our(...)
3379     my $type;
3380     for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
3381         my $lopname = $lop->name;
3382         my $loppriv = $lop->private;
3383         my $newtype;
3384         if ($lopname =~ /^pad[ash]v$/ && $loppriv & OPpLVAL_INTRO) {
3385             if ($loppriv & OPpPAD_STATE) { # state()
3386                 ($local = "", last) if $local !~ /^(?:either|state)$/;
3387                 $local = "state";
3388             } else { # my()
3389                 ($local = "", last) if $local !~ /^(?:either|my)$/;
3390                 $local = "my";
3391             }
3392             my $padname = $self->padname_sv($lop->targ);
3393             if ($padname->FLAGS & SVpad_TYPED) {
3394                 $newtype = $padname->SvSTASH->NAME;
3395             }
3396         } elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/
3397                         && $loppriv & OPpOUR_INTRO
3398                 or $lopname eq "null" && class($lop) eq 'UNOP'
3399                         && $lop->first->name eq "gvsv"
3400                         && $lop->first->private & OPpOUR_INTRO) { # our()
3401             my $newlocal = "local " x !!($loppriv & OPpLVAL_INTRO) . "our";
3402             ($local = "", last)
3403                 if $local ne 'either' && $local ne $newlocal;
3404             $local = $newlocal;
3405             my $funny = !$1 || $1 eq 's' ? '$' : $1 eq 'a' ? '@' : '%';
3406             if (my $t = $self->find_our_type(
3407                     $funny . $self->gv_or_padgv($lop->first)->NAME
3408                )) {
3409                 $newtype = $t;
3410             }
3411         } elsif ($lopname ne 'undef'
3412            and    !($loppriv & OPpLVAL_INTRO)
3413                || !exists $uses_intro{$lopname eq 'null'
3414                                         ? substr B::ppname($lop->targ), 3
3415                                         : $lopname})
3416         {
3417             $local = ""; # or not
3418             last;
3419         } elsif ($lopname ne "undef")
3420         {
3421             # local()
3422             ($local = "", last) if $local !~ /^(?:either|local)$/;
3423             $local = "local";
3424         }
3425         if (defined $type && defined $newtype && $newtype ne $type) {
3426             $local = '';
3427             last;
3428         }
3429         $type = $newtype;
3430     }
3431     $local = "" if $local eq "either"; # no point if it's all undefs
3432     $local &&= join ' ', map $self->keyword($_), split / /, $local;
3433     $local .= " $type " if $local && length $type;
3434     return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
3435     for (; !null($kid); $kid = $kid->sibling) {
3436         if ($local) {
3437             if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
3438                 $lop = $kid->first;
3439             } else {
3440                 $lop = $kid;
3441             }
3442             $self->{'avoid_local'}{$$lop}++;
3443             $expr = $self->deparse($kid, 6);
3444             delete $self->{'avoid_local'}{$$lop};
3445         } else {
3446             $expr = $self->deparse($kid, 6);
3447         }
3448         push @exprs, $expr;
3449     }
3450     if ($local) {
3451         return "$local(" . join(", ", @exprs) . ")";
3452     } else {
3453         return $self->maybe_parens( join(", ", @exprs), $cx, 6);
3454     }
3455 }
3456
3457 sub is_ifelse_cont {
3458     my $op = shift;
3459     return ($op->name eq "null" and class($op) eq "UNOP"
3460             and $op->first->name =~ /^(and|cond_expr)$/
3461             and is_scope($op->first->first->sibling));
3462 }
3463
3464 sub pp_cond_expr {
3465     my $self = shift;
3466     my($op, $cx) = @_;
3467     my $cond = $op->first;
3468     my $true = $cond->sibling;
3469     my $false = $true->sibling;
3470     my $cuddle = $self->{'cuddle'};
3471     unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
3472             (is_scope($false) || is_ifelse_cont($false))
3473             and $self->{'expand'} < 7) {
3474         $cond = $self->deparse($cond, 8);
3475         $true = $self->deparse($true, 6);
3476         $false = $self->deparse($false, 8);
3477         return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
3478     }
3479
3480     $cond = $self->deparse($cond, 1);
3481     $true = $self->deparse($true, 0);
3482     my $head = $self->keyword("if") . " ($cond) {\n\t$true\n\b}";
3483     my @elsifs;
3484     my $elsif;
3485     while (!null($false) and is_ifelse_cont($false)) {
3486         my $newop = $false->first;
3487         my $newcond = $newop->first;
3488         my $newtrue = $newcond->sibling;
3489         $false = $newtrue->sibling; # last in chain is OP_AND => no else
3490         if ($newcond->name eq "lineseq")
3491         {
3492             # lineseq to ensure correct line numbers in elsif()
3493             # Bug #37302 fixed by change #33710.
3494             $newcond = $newcond->first->sibling;
3495         }
3496         $newcond = $self->deparse($newcond, 1);
3497         $newtrue = $self->deparse($newtrue, 0);
3498         $elsif ||= $self->keyword("elsif");
3499         push @elsifs, "$elsif ($newcond) {\n\t$newtrue\n\b}";
3500     }
3501     if (!null($false)) {
3502         $false = $cuddle . $self->keyword("else") . " {\n\t" .
3503           $self->deparse($false, 0) . "\n\b}\cK";
3504     } else {
3505         $false = "\cK";
3506     }
3507     return $head . join($cuddle, "", @elsifs) . $false;
3508 }
3509
3510 sub pp_once {
3511     my ($self, $op, $cx) = @_;
3512     my $cond = $op->first;
3513     my $true = $cond->sibling;
3514
3515     my $ret = $self->deparse($true, $cx);
3516     $ret =~ s/^(\(?)\$/$1 . $self->keyword("state") . ' $'/e;
3517     $ret;
3518 }
3519
3520 sub loop_common {
3521     my $self = shift;
3522     my($op, $cx, $init) = @_;
3523     my $enter = $op->first;
3524     my $kid = $enter->sibling;
3525     local(@$self{qw'curstash warnings hints hinthash'})
3526                 = @$self{qw'curstash warnings hints hinthash'};
3527     my $head = "";
3528     my $bare = 0;
3529     my $body;
3530     my $cond = undef;
3531     my $name;
3532     if ($kid->name eq "lineseq") { # bare or infinite loop
3533         if ($kid->last->name eq "unstack") { # infinite
3534             $head = "while (1) "; # Can't use for(;;) if there's a continue
3535             $cond = "";
3536         } else {
3537             $bare = 1;
3538         }
3539         $body = $kid;
3540     } elsif ($enter->name eq "enteriter") { # foreach
3541         my $ary = $enter->first->sibling; # first was pushmark
3542         my $var = $ary->sibling;
3543         if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
3544             # "reverse" was optimised away
3545             $ary = listop($self, $ary->first->sibling, 1, 'reverse');
3546         } elsif ($enter->flags & OPf_STACKED
3547             and not null $ary->first->sibling->sibling)
3548         {
3549             $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
3550               $self->deparse($ary->first->sibling->sibling, 9);
3551         } else {
3552             $ary = $self->deparse($ary, 1);
3553         }
3554         if (null $var) {
3555             $var = $self->pp_padsv($enter, 1, 1);
3556         } elsif ($var->name eq "rv2gv") {
3557             $var = $self->pp_rv2sv($var, 1);
3558             if ($enter->private & OPpOUR_INTRO) {
3559                 # our declarations don't have package names
3560                 $var =~ s/^(.).*::/$1/;
3561                 $var = "our $var";
3562             }
3563         } elsif ($var->name eq "gv") {
3564             $var = "\$" . $self->deparse($var, 1);
3565         } else {
3566             $var = $self->deparse($var, 1);
3567         }
3568         $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
3569         if (!is_state $body->first and $body->first->name !~ /^(?:stub|leave|scope)$/) {
3570             confess unless $var eq '$_';
3571             $body = $body->first;
3572             return $self->deparse($body, 2) . " "
3573                  . $self->keyword("foreach") . " ($ary)";
3574         }
3575         $head = "foreach $var ($ary) ";
3576     } elsif ($kid->name eq "null") { # while/until
3577         $kid = $kid->first;
3578         $name = {"and" => "while", "or" => "until"}->{$kid->name};
3579         $cond = $kid->first;
3580         $body = $kid->first->sibling;
3581     } elsif ($kid->name eq "stub") { # bare and empty
3582         return "{;}"; # {} could be a hashref
3583     }
3584     # If there isn't a continue block, then the next pointer for the loop
3585     # will point to the unstack, which is kid's last child, except
3586     # in a bare loop, when it will point to the leaveloop. When neither of
3587     # these conditions hold, then the second-to-last child is the continue
3588     # block (or the last in a bare loop).
3589     my $cont_start = $enter->nextop;
3590     my $cont;
3591     my $precond;
3592     my $postcond;
3593     if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
3594         if ($bare) {
3595             $cont = $body->last;
3596         } else {
3597             $cont = $body->first;
3598             while (!null($cont->sibling->sibling)) {
3599                 $cont = $cont->sibling;
3600             }
3601         }
3602         my $state = $body->first;
3603         my $cuddle = $self->{'cuddle'};
3604         my @states;
3605         for (; $$state != $$cont; $state = $state->sibling) {
3606             push @states, $state;
3607         }
3608         $body = $self->lineseq(undef, 0, @states);
3609         if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
3610             $precond = "for ($init; ";
3611             $postcond = "; " . $self->deparse($cont, 1) .") ";
3612             $cont = "\cK";
3613         } else {
3614             $cont = $cuddle . "continue {\n\t" .
3615               $self->deparse($cont, 0) . "\n\b}\cK";
3616         }
3617     } else {
3618         return "" if !defined $body;
3619         if (length $init) {
3620             $precond = "for ($init; ";
3621             $postcond = ";) ";
3622         }
3623         $cont = "\cK";
3624         $body = $self->deparse($body, 0);
3625     }
3626     if ($precond) { # for(;;)
3627         $cond &&= $name eq 'until'
3628                     ? listop($self, undef, 1, "not", $cond->first)
3629                     : $self->deparse($cond, 1);
3630         $head = "$precond$cond$postcond";
3631     }
3632     if ($name && !$head) {
3633         ref $cond and $cond = $self->deparse($cond, 1);
3634         $head = "$name ($cond) ";
3635     }
3636     $head =~ s/^(for(?:each)?|while|until)/$self->keyword($1)/e;
3637     $body =~ s/;?$/;\n/;
3638
3639     return $head . "{\n\t" . $body . "\b}" . $cont;
3640 }
3641
3642 sub pp_leaveloop { shift->loop_common(@_, "") }
3643
3644 sub for_loop {
3645     my $self = shift;
3646     my($op, $cx) = @_;
3647     my $init = $self->deparse($op, 1);
3648     my $s = $op->sibling;
3649     my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling;
3650     return $self->loop_common($ll, $cx, $init);
3651 }
3652
3653 sub pp_leavetry {
3654     my $self = shift;
3655     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
3656 }
3657
3658 sub _op_is_or_was {
3659   my ($op, $expect_type) = @_;
3660   my $type = $op->type;
3661   return($type == $expect_type
3662          || ($type == OP_NULL && $op->targ == $expect_type));
3663 }
3664
3665 sub pp_null {
3666     my($self, $op, $cx) = @_;
3667     if (class($op) eq "OP") {
3668         # old value is lost
3669         return $self->{'ex_const'} if $op->targ == OP_CONST;
3670     } elsif (class ($op) eq "COP") {
3671             return &pp_nextstate;
3672     } elsif ($op->first->name eq 'pushmark'
3673              or $op->first->name eq 'null'
3674                 && $op->first->targ == OP_PUSHMARK
3675                 && _op_is_or_was($op, OP_LIST)) {
3676         return $self->pp_list($op, $cx);
3677     } elsif ($op->first->name eq "enter") {
3678         return $self->pp_leave($op, $cx);
3679     } elsif ($op->first->name eq "leave") {
3680         return $self->pp_leave($op->first, $cx);
3681     } elsif ($op->first->name eq "scope") {
3682         return $self->pp_scope($op->first, $cx);
3683     } elsif ($op->targ == OP_STRINGIFY) {
3684         return $self->dquote($op, $cx);
3685     } elsif ($op->targ == OP_GLOB) {
3686         return $self->pp_glob(
3687                  $op->first    # entersub
3688                     ->first    # ex-list
3689                     ->first    # pushmark
3690                     ->sibling, # glob
3691                  $cx
3692                );
3693     } elsif (!null($op->first->sibling) and
3694              $op->first->sibling->name eq "readline" and
3695              $op->first->sibling->flags & OPf_STACKED) {
3696         return $self->maybe_parens($self->deparse($op->first, 7) . " = "
3697                                    . $self->deparse($op->first->sibling, 7),
3698                                    $cx, 7);
3699     } elsif (!null($op->first->sibling) and
3700              $op->first->sibling->name =~ /^transr?\z/ and
3701              $op->first->sibling->flags & OPf_STACKED) {
3702         return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
3703                                    . $self->deparse($op->first->sibling, 20),
3704                                    $cx, 20);
3705     } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
3706         return ($self->lex_in_scope("&do") ? "CORE::do" : "do")
3707              . " {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
3708     } elsif (!null($op->first->sibling) and
3709              $op->first->sibling->name eq "null" and
3710              class($op->first->sibling) eq "UNOP" and
3711              $op->first->sibling->first->flags & OPf_STACKED and
3712              $op->first->sibling->first->name eq "rcatline") {
3713         return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
3714                                    . $self->deparse($op->first->sibling, 18),
3715                                    $cx, 18);
3716     } else {
3717         return $self->deparse($op->first, $cx);
3718     }
3719 }
3720
3721 sub padname {
3722     my $self = shift;
3723     my $targ = shift;
3724     return $self->padname_sv($targ)->PVX;
3725 }
3726
3727 sub padany {
3728     my $self = shift;
3729     my $op = shift;
3730     return substr($self->padname($op->targ), 1); # skip $/@/%
3731 }
3732
3733 sub pp_padsv {
3734     my $self = shift;
3735     my($op, $cx, $forbid_parens) = @_;
3736     my $targ = $op->targ;
3737     return $self->maybe_my($op, $cx, $self->padname($targ),
3738                            $self->padname_sv($targ),
3739                            $forbid_parens);
3740 }
3741
3742 sub pp_padav { pp_padsv(@_) }
3743 sub pp_padhv { pp_padsv(@_) }
3744
3745 sub gv_or_padgv {
3746     my $self = shift;
3747     my $op = shift;
3748     if (class($op) eq "PADOP") {
3749         return $self->padval($op->padix);
3750     } else { # class($op) eq "SVOP"
3751         return $op->gv;
3752     }
3753 }
3754
3755 sub pp_gvsv {
3756     my $self = shift;
3757     my($op, $cx) = @_;
3758     my $gv = $self->gv_or_padgv($op);
3759     return $self->maybe_local($op, $cx, $self->stash_variable("\$",
3760                                  $self->gv_name($gv), $cx));
3761 }
3762
3763 sub pp_gv {
3764     my $self = shift;
3765     my($op, $cx) = @_;
3766     my $gv = $self->gv_or_padgv($op);
3767     return $self->gv_name($gv);
3768 }
3769
3770 sub pp_aelemfast_lex {
3771     my $self = shift;
3772     my($op, $cx) = @_;
3773     my $name = $self->padname($op->targ);
3774     $name =~ s/^@/\$/;
3775     my $i = $op->private;
3776     $i -= 256 if $i > 127;
3777     return $name . "[" .  ($i + $self->{'arybase'}) . "]";
3778 }
3779
3780 sub pp_aelemfast {
3781     my $self = shift;
3782     my($op, $cx) = @_;
3783     # optimised PADAV, pre 5.15
3784     return $self->pp_aelemfast_lex(@_) if ($op->flags & OPf_SPECIAL);
3785
3786     my $gv = $self->gv_or_padgv($op);
3787     my($name,$quoted) = $self->stash_variable_name('@',$gv);
3788     $name = $quoted ? "$name->" : '$' . $name;
3789     my $i = $op->private;
3790     $i -= 256 if $i > 127;
3791     return $name . "[" .  ($i + $self->{'arybase'}) . "]";
3792 }
3793
3794 sub rv2x {
3795     my $self = shift;
3796     my($op, $cx, $type) = @_;
3797
3798     if (class($op) eq 'NULL' || !$op->can("first")) {
3799         carp("Unexpected op in pp_rv2x");
3800         return 'XXX';
3801     }
3802     my $kid = $op->first;
3803     if ($kid->name eq "gv") {
3804         return $self->stash_variable($type, $self->deparse($kid, 0), $cx);
3805     } elsif (is_scalar $kid) {
3806         my $str = $self->deparse($kid, 0);
3807         if ($str =~ /^\$([^\w\d])\z/) {
3808             # "$$+" isn't a legal way to write the scalar dereference
3809             # of $+, since the lexer can't tell you aren't trying to
3810             # do something like "$$ + 1" to get one more than your
3811             # PID. Either "${$+}" or "$${+}" are workable
3812             # disambiguations, but if the programmer did the former,
3813             # they'd be in the "else" clause below rather than here.
3814             # It's not clear if this should somehow be unified with
3815             # the code in dq and re_dq that also adds lexer
3816             # disambiguation braces.
3817             $str = '$' . "{$1}"; #'
3818         }
3819         return $type . $str;
3820     } else {
3821         return $type . "{" . $self->deparse($kid, 0) . "}";
3822     }
3823 }
3824
3825 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
3826 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
3827 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
3828
3829 # skip rv2av
3830 sub pp_av2arylen {
3831     my $self = shift;
3832     my($op, $cx) = @_;
3833     if ($op->first->name eq "padav") {
3834         return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
3835     } else {
3836         return $self->maybe_local($op, $cx,
3837                                   $self->rv2x($op->first, $cx, '$#'));
3838     }
3839 }
3840
3841 # skip down to the old, ex-rv2cv
3842 sub pp_rv2cv {
3843     my ($self, $op, $cx) = @_;
3844     if (!null($op->first) && $op->first->name eq 'null' &&
3845         $op->first->targ == OP_LIST)
3846     {
3847         return $self->rv2x($op->first->first->sibling, $cx, "&")
3848     }
3849     else {
3850         return $self->rv2x($op, $cx, "")
3851     }
3852 }
3853
3854 sub list_const {
3855     my $self = shift;
3856     my($cx, @list) = @_;
3857     my @a = map $self->const($_, 6), @list;
3858     if (@a == 0) {
3859         return "()";
3860     } elsif (@a == 1) {
3861         return $a[0];
3862     } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
3863         # collapse (-1,0,1,2) into (-1..2)
3864         my ($s, $e) = @a[0,-1];
3865         my $i = $s;
3866         return $self->maybe_parens("$s..$e", $cx, 9)
3867           unless grep $i++ != $_, @a;
3868     }
3869     return $self->maybe_parens(join(", ", @a), $cx, 6);
3870 }
3871
3872 sub pp_rv2av {
3873     my $self = shift;
3874     my($op, $cx) = @_;
3875     my $kid = $op->first;
3876     if ($kid->name eq "const") { # constant list
3877         my $av = $self->const_sv($kid);
3878         return $self->list_const($cx, $av->ARRAY);
3879     } else {
3880         return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
3881     }
3882  }
3883
3884 sub is_subscriptable {
3885     my $op = shift;
3886     if ($op->name =~ /^([ahg]elem|multideref$)/) {
3887         return 1;
3888     } elsif ($op->name eq "entersub") {
3889         my $kid = $op->first;
3890         return 0 unless null $kid->sibling;
3891         $kid = $kid->first;
3892         $kid = $kid->sibling until null $kid->sibling;
3893         return 0 if is_scope($kid);
3894         $kid = $kid->first;
3895         return 0 if $kid->name eq "gv" || $kid->name eq "padcv";
3896         return 0 if is_scalar($kid);
3897         return is_subscriptable($kid);
3898     } else {
3899         return 0;
3900     }
3901 }
3902
3903 sub elem_or_slice_array_name
3904 {
3905     my $self = shift;
3906     my ($array, $left, $padname, $allow_arrow) = @_;
3907
3908     if ($array->name eq $padname) {
3909         return $self->padany($array);
3910     } elsif (is_scope($array)) { # ${expr}[0]
3911         return "{" . $self->deparse($array, 0) . "}";
3912     } elsif ($array->name eq "gv") {
3913         ($array, my $quoted) =
3914             $self->stash_variable_name(
3915                 $left eq '[' ? '@' : '%', $self->gv_or_padgv($array)
3916             );
3917         if (!$allow_arrow && $quoted) {
3918             # This cannot happen.
3919             die "Invalid variable name $array for slice";
3920         }
3921         return $quoted ? "$array->" : $array;
3922     } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
3923         return $self->deparse($array, 24);
3924     } else {
3925         return undef;
3926     }
3927 }
3928
3929 sub elem_or_slice_single_index
3930 {
3931     my $self = shift;
3932     my ($idx) = @_;
3933
3934     $idx = $self->deparse($idx, 1);
3935
3936     # Outer parens in an array index will confuse perl
3937     # if we're interpolating in a regular expression, i.e.
3938     # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
3939     #
3940     # If $self->{parens}, then an initial '(' will
3941     # definitely be paired with a final ')'. If
3942     # !$self->{parens}, the misleading parens won't
3943     # have been added in the first place.
3944     #
3945     # [You might think that we could get "(...)...(...)"
3946     # where the initial and final parens do not match
3947     # each other. But we can't, because the above would
3948     # only happen if there's an infix binop between the
3949     # two pairs of parens, and *that* means that the whole
3950     # expression would be parenthesized as well.]
3951     #
3952     $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
3953
3954     # Hash-element braces will autoquote a bareword inside themselves.
3955     # We need to make sure that C<$hash{warn()}> doesn't come out as
3956     # C<$hash{warn}>, which has a quite different meaning. Currently
3957     # B::Deparse will always quote strings, even if the string was a
3958     # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
3959     # for constant strings.) So we can cheat slightly here - if we see
3960     # a bareword, we know that it is supposed to be a function call.
3961     #
3962     $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
3963
3964     return $idx;
3965 }
3966
3967 sub elem {
3968     my $self = shift;
3969     my ($op, $cx, $left, $right, $padname) = @_;
3970     my($array, $idx) = ($op->first, $op->first->sibling);
3971
3972     $idx = $self->elem_or_slice_single_index($idx);
3973
3974     unless ($array->name eq $padname) { # Maybe this has been fixed
3975         $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
3976     }
3977     if (my $array_name=$self->elem_or_slice_array_name
3978             ($array, $left, $padname, 1)) {
3979         return ($array_name =~ /->\z/
3980                     ? $array_name
3981                     : $array_name eq '#' ? '${#}' : "\$" . $array_name)
3982               . $left . $idx . $right;
3983     } else {
3984         # $x[20][3]{hi} or expr->[20]
3985         my $arrow = is_subscriptable($array) ? "" : "->";
3986         return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
3987     }
3988
3989 }
3990
3991 # a simplified version of elem_or_slice_array_name()
3992 # for the use of pp_multideref
3993
3994 sub multideref_var_name {
3995     my $self = shift;
3996     my ($gv, $is_hash) = @_;
3997
3998     my ($name, $quoted) =
3999         $self->stash_variable_name( $is_hash  ? '%' : '@', $gv);
4000     return $quoted ? "$name->"
4001                    : $name eq '#'
4002                         ? '${#}'       # avoid ${#}[1] => $#[1]
4003                         : '$' . $name;
4004 }
4005
4006
4007 sub pp_multideref {
4008     my $self = shift;
4009     my($op, $cx) = @_;
4010     my $text = "";
4011
4012     if ($op->private & OPpMULTIDEREF_EXISTS) {
4013         $text = $self->keyword("exists"). " ";
4014     }
4015     elsif ($op->private & OPpMULTIDEREF_DELETE) {
4016         $text = $self->keyword("delete"). " ";
4017     }
4018     elsif ($op->private & OPpLVAL_INTRO) {
4019         $text = $self->keyword("local"). " ";
4020     }
4021
4022     if ($op->first && ($op->first->flags & OPf_KIDS)) {
4023         # arbitrary initial expression, e.g. f(1,2,3)->[...]
4024         $text .=  $self->deparse($op->first, 24);
4025     }
4026
4027     my @items = $op->aux_list($self->{curcv});
4028     my $actions = shift @items;
4029
4030     my $is_hash;
4031     my $derefs = 0;
4032
4033     while (1) {
4034         if (($actions & MDEREF_ACTION_MASK) == MDEREF_reload) {
4035             $actions = shift @items;
4036             next;
4037         }
4038
4039         $is_hash = (
4040            ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_pop_rv2hv_helem
4041         || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvsv_vivify_rv2hv_helem
4042         || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padsv_vivify_rv2hv_helem
4043         || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_vivify_rv2hv_helem
4044         || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem
4045         || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem
4046         );
4047
4048         if (   ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_padav_aelem
4049             || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem)
4050         {
4051             $derefs = 1;
4052             $text .= '$' . substr($self->padname(shift @items), 1);
4053         }
4054         elsif (   ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_gvav_aelem
4055                || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem)
4056         {
4057             $derefs = 1;
4058             $text .= $self->multideref_var_name(shift @items, $is_hash);
4059         }
4060         else {
4061             if (   ($actions & MDEREF_ACTION_MASK) ==
4062                                         MDEREF_AV_padsv_vivify_rv2av_aelem
4063                 || ($actions & MDEREF_ACTION_MASK) ==
4064                                         MDEREF_HV_padsv_vivify_rv2hv_helem)
4065             {
4066                 $text .= $self->padname(shift @items);
4067             }
4068             elsif (   ($actions & MDEREF_ACTION_MASK) ==
4069                                            MDEREF_AV_gvsv_vivify_rv2av_aelem
4070                    || ($actions & MDEREF_ACTION_MASK) ==
4071                                            MDEREF_HV_gvsv_vivify_rv2hv_helem)
4072             {
4073                 $text .= $self->multideref_var_name(shift @items, $is_hash);
4074             }
4075             elsif (   ($actions & MDEREF_ACTION_MASK) ==
4076                                            MDEREF_AV_pop_rv2av_aelem
4077                    || ($actions & MDEREF_ACTION_MASK) ==
4078                                            MDEREF_HV_pop_rv2hv_helem)
4079             {
4080                 if (   ($op->flags & OPf_KIDS)
4081                     && (   _op_is_or_was($op->first, OP_RV2AV)
4082                         || _op_is_or_was($op->first, OP_RV2HV))
4083                     && ($op->first->flags & OPf_KIDS)
4084                     && (   _op_is_or_was($op->first->first, OP_AELEM)
4085                         || _op_is_or_was($op->first->first, OP_HELEM))
4086                     )
4087                 {
4088                     $derefs++;
4089                 }
4090             }
4091
4092             $text .= '->' if !$derefs++;
4093         }
4094
4095
4096         if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_none) {
4097             last;
4098         }
4099
4100         $text .= $is_hash ? '{' : '[';
4101
4102         if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_const) {
4103             my $key = shift @items;
4104             if ($is_hash) {
4105                 $text .= $self->const($key, $cx);
4106             }
4107             else {
4108                 $text .= $key;
4109             }
4110         }
4111         elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_padsv) {
4112             $text .= $self->padname(shift @items);
4113         }
4114         elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_gvsv) {
4115             $text .= '$' .  ($self->stash_variable_name('$', shift @items))[0];
4116         }
4117
4118         $text .= $is_hash ? '}' : ']';
4119
4120         if ($actions & MDEREF_FLAG_last) {
4121             last;
4122         }
4123         $actions >>= MDEREF_SHIFT;
4124     }
4125
4126     return $text;
4127 }
4128
4129
4130 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
4131 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
4132
4133 sub pp_gelem {
4134     my $self = shift;
4135     my($op, $cx) = @_;
4136     my($glob, $part) = ($op->first, $op->last);
4137     $glob = $glob->first; # skip rv2gv
4138     $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
4139     my $scope = is_scope($glob);
4140     $glob = $self->deparse($glob, 0);
4141     $part = $self->deparse($part, 1);
4142     return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
4143 }
4144
4145 sub slice {
4146     my $self = shift;
4147     my ($op, $cx, $left, $right, $regname, $padname) = @_;
4148     my $last;
4149     my(@elems, $kid, $array, $list);
4150     if (class($op) eq "LISTOP") {
4151         $last = $op->last;
4152     } else { # ex-hslice inside delete()
4153         for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
4154         $last = $kid;
4155     }
4156     $array = $last;
4157     $array = $array->first
4158         if $array->name eq $regname or $array->name eq "null";
4159     $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
4160     $kid = $op->first->sibling; # skip pushmark
4161     if ($kid->name eq "list") {
4162         $kid = $kid->first->sibling; # skip list, pushmark
4163         for (; !null $kid; $kid = $kid->sibling) {
4164             push @elems, $self->deparse($kid, 6);
4165         }
4166         $list = join(", ", @elems);
4167     } else {
4168         $list = $self->elem_or_slice_single_index($kid);
4169     }
4170     my $lead = '@';
4171     $lead = '%' if $op->name =~ /^kv/i;
4172     return $lead . $array . $left . $list . $right;
4173 }
4174
4175 sub pp_aslice   { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
4176 sub pp_kvaslice {                 slice(@_, "[", "]", "rv2av", "padav")  }
4177 sub pp_hslice   { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
4178 sub pp_kvhslice {                 slice(@_, "{", "}", "rv2hv", "padhv")  }
4179
4180 sub pp_lslice {
4181     my $self = shift;
4182     my($op, $cx) = @_;
4183     my $idx = $op->first;
4184     my $list = $op->last;
4185     my(@elems, $kid);
4186     $list = $self->deparse($list, 1);
4187     $idx = $self->deparse($idx, 1);
4188     return "($list)" . "[$idx]";
4189 }
4190
4191 sub want_scalar {
4192     my $op = shift;
4193     return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
4194 }
4195
4196 sub want_list {
4197     my $op = shift;
4198     return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
4199 }
4200
4201 sub _method {
4202     my $self = shift;
4203     my($op, $cx) = @_;
4204     my $kid = $op->first->sibling; # skip pushmark
4205     my($meth, $obj, @exprs);
4206     if ($kid->name eq "list" and want_list $kid) {
4207         # When an indirect object isn't a bareword but the args are in
4208         # parens, the parens aren't part of the method syntax (the LLAFR
4209         # doesn't apply), but they make a list with OPf_PARENS set that
4210         # doesn't get flattened by the append_elem that adds the method,
4211         # making a (object, arg1, arg2, ...) list where the object
4212         # usually is. This can be distinguished from
4213         # '($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
4214         # object) because in the later the list is in scalar context
4215         # as the left side of -> always is, while in the former
4216         # the list is in list context as method arguments always are.
4217         # (Good thing there aren't method prototypes!)
4218         $meth = $kid->sibling;
4219         $kid = $kid->first->sibling; # skip pushmark
4220         $obj = $kid;
4221         $kid = $kid->sibling;
4222         for (; not null $kid; $kid = $kid->sibling) {
4223             push @exprs, $kid;
4224         }
4225     } else {
4226         $obj = $kid;
4227         $kid = $kid->sibling;
4228         for (; !null ($kid->sibling) && $kid->name!~/^method(?:_named)?\z/;
4229               $kid = $kid->sibling) {
4230             push @exprs, $kid
4231         }
4232         $meth = $kid;
4233     }
4234
4235     if ($meth->name eq "method_named") {
4236         $meth = $self->meth_sv($meth)->PV;
4237     } elsif ($meth->name eq "method_super") {
4238         $meth = "SUPER::".$self->meth_sv($meth)->PV;
4239     } elsif ($meth->name eq "method_redir") {
4240         $meth = $self->meth_rclass_sv($meth)->PV.'::'.$self->meth_sv($meth)->PV;
4241     } elsif ($meth->name eq "method_redir_super") {
4242         $meth = $self->meth_rclass_sv($meth)->PV.'::SUPER::'.
4243                 $self->meth_sv($meth)->PV;
4244     } else {
4245         $meth = $meth->first;
4246         if ($meth->name eq "const") {
4247             # As of 5.005_58, this case is probably obsoleted by the
4248             # method_named case above
4249             $meth = $self->const_sv($meth)->PV; # needs to be bare
4250         }
4251     }
4252
4253     return { method => $meth, variable_method => ref($meth),
4254              object => $obj, args => \@exprs  },
4255            $cx;
4256 }
4257
4258 # compat function only
4259 sub method {
4260     my $self = shift;
4261     my $info = $self->_method(@_);
4262     return $self->e_method( $self->_method(@_) );
4263 }
4264
4265 sub e_method {
4266     my ($self, $info, $cx) = @_;
4267     my $obj = $self->deparse($info->{object}, 24);
4268
4269     my $meth = $info->{method};
4270     $meth = $self->deparse($meth, 1) if $info->{variable_method};
4271     my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
4272     if ($info->{object}->name eq 'scope' && want_list $info->{object}) {
4273         # method { $object }
4274         # This must be deparsed this way to preserve list context
4275         # of $object.
4276         my $need_paren = $cx >= 6;
4277         return '(' x $need_paren
4278              . $meth . substr($obj,2) # chop off the "do"
4279              . " $args"
4280              . ')' x $need_paren;
4281     }
4282     my $kid = $obj . "->" . $meth;
4283     if (length $args) {
4284         return $kid . "(" . $args . ")"; # parens mandatory
4285     } else {
4286         return $kid;
4287     }
4288 }
4289
4290 # returns "&" if the prototype doesn't match the args,
4291 # or ("", $args_after_prototype_demunging) if it does.
4292 sub check_proto {
4293     my $self = shift;
4294     return "&" if $self->{'noproto'};
4295     my($proto, @args) = @_;
4296     my($arg, $real);
4297     my $doneok = 0;
4298     my @reals;
4299     # An unbackslashed @ or % gobbles up the rest of the args
4300     1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
4301     $proto =~ s/^\s*//;
4302     while ($proto) {
4303         $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;|)\s*//;
4304         my $chr = $1;
4305         if ($chr eq "") {
4306             return "&" if @args;
4307         } elsif ($chr eq ";") {
4308             $doneok = 1;
4309         } elsif ($chr eq "@" or $chr eq "%") {
4310             push @reals, map($self->deparse($_, 6), @args);
4311             @args = ();
4312         } else {
4313             $arg = shift @args;
4314             last unless $arg;
4315             if ($chr eq "\$" || $chr eq "_") {
4316                 if (want_scalar $arg) {
4317                     push @reals, $self->deparse($arg, 6);
4318                 } else {
4319                     return "&";
4320                 }
4321             } elsif ($chr eq "&") {
4322                 if ($arg->name =~ /^(s?refgen|undef)$/) {
4323                     push @reals, $self->deparse($arg, 6);
4324                 } else {
4325                     return "&";
4326                 }
4327             } elsif ($chr eq "*") {
4328                 if ($arg->name =~ /^s?refgen$/
4329                     and $arg->first->first->name eq "rv2gv")
4330                   {
4331                       $real = $arg->first->first; # skip refgen, null
4332                       if ($real->first->name eq "gv") {
4333                           push @reals, $self->deparse($real, 6);
4334                       } else {
4335                           push @reals, $self->deparse($real->first, 6);
4336                       }
4337                   } else {
4338                       return "&";
4339                   }
4340             } elsif (substr($chr, 0, 1) eq "\\") {
4341                 $chr =~ tr/\\[]//d;
4342                 if ($arg->name =~ /^s?refgen$/ and
4343                     !null($real = $arg->first) and
4344                     ($chr =~ /\$/ && is_scalar($real->first)
4345                      or ($chr =~ /@/
4346                          && class($real->first->sibling) ne 'NULL'
4347                          && $real->first->sibling->name
4348                          =~ /^(rv2|pad)av$/)
4349                      or ($chr =~ /%/
4350                          && class($real->first->sibling) ne 'NULL'
4351                          && $real->first->sibling->name
4352                          =~ /^(rv2|pad)hv$/)
4353                      #or ($chr =~ /&/ # This doesn't work
4354                      #   && $real->first->name eq "rv2cv")
4355                      or ($chr =~ /\*/
4356                          && $real->first->name eq "rv2gv")))
4357                   {
4358                       push @reals, $self->deparse($real, 6);
4359                   } else {
4360                       return "&";
4361                   }
4362             }
4363        }
4364     }
4365     return "&" if $proto and !$doneok; # too few args and no ';'
4366     return "&" if @args;               # too many args
4367     return ("", join ", ", @reals);
4368 }
4369
4370 sub retscalar {
4371     my $name = $_[0]->name;
4372     # XXX There has to be a better way of doing this scalar-op check.
4373     #     Currently PL_opargs is not exposed.
4374     if ($name eq 'null') {
4375         $name = substr B::ppname($_[0]->targ), 3
4376     }
4377     $name =~ /^(?:scalar|pushmark|wantarray|const|gvsv|gv|padsv|rv2gv
4378                  |rv2sv|av2arylen|anoncode|prototype|srefgen|ref|bless
4379                  |regcmaybe|regcreset|regcomp|qr|subst|substcont|trans
4380                  |transr|sassign|chop|schop|chomp|schomp|defined|undef
4381                  |study|pos|preinc|i_preinc|predec|i_predec|postinc
4382                  |i_postinc|postdec|i_postdec|pow|multiply|i_multiply
4383                  |divide|i_divide|modulo|i_modulo|add|i_add|subtract
4384                  |i_subtract|concat|stringify|left_shift|right_shift|lt
4385                  |i_lt|gt|i_gt|le|i_le|ge|i_ge|eq|i_eq|ne|i_ne|ncmp|i_ncmp
4386                  |slt|sgt|sle|sge|seq|sne|scmp|[sn]?bit_(?:and|x?or)|negate
4387                  |i_negate|not|[sn]?complement|smartmatch|atan2|sin|cos
4388                  |rand|srand|exp|log|sqrt|int|hex|oct|abs|length|substr
4389                  |vec|index|rindex|sprintf|formline|ord|chr|crypt|ucfirst
4390                  |lcfirst|uc|lc|quotemeta|aelemfast|aelem|exists|helem
4391                  |pack|join|anonlist|anonhash|push|pop|shift|unshift|xor
4392                  |andassign|orassign|dorassign|warn|die|reset|nextstate
4393                  |dbstate|unstack|last|next|redo|dump|goto|exit|open|close
4394                  |pipe_op|fileno|umask|binmode|tie|untie|tied|dbmopen
4395                  |dbmclose|select|getc|read|enterwrite|prtf|print|say
4396                  |sysopen|sysseek|sysread|syswrite|eof|tell|seek|truncate
4397                  |fcntl|ioctl|flock|send|recv|socket|sockpair|bind|connect
4398                  |listen|accept|shutdown|gsockopt|ssockopt|getsockname
4399                  |getpeername|ftrread|ftrwrite|ftrexec|fteread|ftewrite
4400                  |fteexec|ftis|ftsize|ftmtime|ftatime|ftctime|ftrowned
4401                  |fteowned|ftzero|ftsock|ftchr|ftblk|ftfile|ftdir|ftpipe
4402                  |ftsuid|ftsgid|ftsvtx|ftlink|fttty|fttext|ftbinary|chdir
4403                  |chown|chroot|unlink|chmod|utime|rename|link|symlink
4404                  |readlink|mkdir|rmdir|open_dir|telldir|seekdir|rewinddir
4405                  |closedir|fork|wait|waitpid|system|exec|kill|getppid
4406                  |getpgrp|setpgrp|getpriority|setpriority|time|alarm|sleep
4407                  |shmget|shmctl|shmread|shmwrite|msgget|msgctl|msgsnd
4408                  |msgrcv|semop|semget|semctl|hintseval|shostent|snetent
4409                  |sprotoent|sservent|ehostent|enetent|eprotoent|eservent
4410                  |spwent|epwent|sgrent|egrent|getlogin|syscall|lock|runcv
4411                  |fc)\z/x
4412 }
4413
4414 sub pp_entersub {
4415     my $self = shift;
4416     my($op, $cx) = @_;
4417     return $self->e_method($self->_method($op, $cx))
4418         unless null $op->first->sibling;
4419     my $prefix = "";
4420     my $amper = "";
4421     my($kid, @exprs);
4422     if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
4423         $prefix = "do ";
4424     } elsif ($op->private & OPpENTERSUB_AMPER) {
4425         $amper = "&";
4426     }
4427     $kid = $op->first;
4428     $kid = $kid->first->sibling; # skip ex-list, pushmark
4429     for (; not null $kid->sibling; $kid = $kid->sibling) {
4430         push @exprs, $kid;
4431     }
4432     my $simple = 0;
4433     my $proto = undef;
4434     my $lexical;
4435     if (is_scope($kid)) {
4436         $amper = "&";
4437         $kid = "{" . $self->deparse($kid, 0) . "}";
4438     } elsif ($kid->first->name eq "gv") {
4439         my $gv = $self->gv_or_padgv($kid->first);
4440         my $cv;
4441         if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL"
4442          || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') {
4443             $proto = $cv->PV if $cv->FLAGS & SVf_POK;
4444         }
4445         $simple = 1; # only calls of named functions can be prototyped
4446         $kid = $self->deparse($kid, 24);
4447         my $fq;
4448         # Fully qualify any sub name that conflicts with a lexical.
4449         if ($self->lex_in_scope("&$kid")
4450          || $self->lex_in_scope("&$kid", 1))
4451         {
4452             $fq++;
4453         } elsif (!$amper) {
4454             if ($kid eq 'main::') {
4455                 $kid = '::';
4456             }
4457             else {
4458               if ($kid !~ /::/ && $kid ne 'x') {
4459                 # Fully qualify any sub name that is also a keyword.  While
4460                 # we could check the import flag, we cannot guarantee that
4461                 # the code deparsed so far would set that flag, so we qual-
4462                 # ify the names regardless of importation.
4463                 if (exists $feature_keywords{$kid}) {
4464                     $fq++ if $self->feature_enabled($kid);
4465                 } elsif (do { local $@; local $SIG{__DIE__};
4466                               eval { () = prototype "CORE::$kid"; 1 } }) {
4467                     $fq++
4468                 }
4469               }
4470               if ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
4471                 $kid = single_delim("q", "'", $kid, $self) . '->';
4472               }
4473             }
4474         }
4475         $fq and substr $kid, 0, 0, = $self->{'curstash'}.'::';
4476     } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
4477         $amper = "&";
4478         $kid = $self->deparse($kid, 24);
4479     } else {
4480         $prefix = "";
4481         my $grandkid = $kid->first;
4482         my $arrow = ($lexical = $grandkid->name eq "padcv")
4483                  || is_subscriptable($grandkid)
4484                     ? ""
4485                     : "->";
4486         $kid = $self->deparse($kid, 24) . $arrow;
4487         if ($lexical) {
4488             my $padlist = $self->{'curcv'}->PADLIST;
4489             my $padoff = $grandkid->targ;
4490             my $padname = $padlist->ARRAYelt(0)->ARRAYelt($padoff);
4491             my $protocv = $padname->FLAGS & SVpad_STATE
4492                 ? $padlist->ARRAYelt(1)->ARRAYelt($padoff)
4493                 : $padname->PROTOCV;
4494             if ($protocv->FLAGS & SVf_POK) {
4495                 $proto = $protocv->PV
4496             }
4497             $simple = 1;
4498         }
4499     }
4500
4501     # Doesn't matter how many prototypes there are, if
4502     # they haven't happened yet!
4503     my $declared = $lexical || exists $self->{'subs_declared'}{$kid};
4504     if (not $declared and $self->{'in_coderef2text'}) {
4505         no strict 'refs';
4506         no warnings 'uninitialized';
4507         $declared =
4508                (
4509                  defined &{ ${$self->{'curstash'}."::"}{$kid} }
4510                  && !exists
4511                      $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
4512                  && defined prototype $self->{'curstash'}."::".$kid
4513                );
4514     }
4515     if (!$declared && defined($proto)) {
4516         # Avoid "too early to check prototype" warning
4517         ($amper, $proto) = ('&');
4518     }
4519
4520     my $args;
4521     my $listargs = 1;
4522     if ($declared and defined $proto and not $amper) {
4523         ($amper, $args) = $self->check_proto($proto, @exprs);
4524         $listargs = $amper;
4525     }
4526     if ($listargs) {
4527         $args = join(", ", map(
4528                     ($_->flags & OPf_WANT) == OPf_WANT_SCALAR
4529                  && !retscalar($_)
4530                         ? $self->maybe_parens_unop('scalar', $_, 6)
4531                         : $self->deparse($_, 6),
4532                     @exprs
4533                 ));
4534     }
4535     if ($prefix or $amper) {
4536         if ($kid eq '&') { $kid = "{$kid}" } # &{&} cannot be written as &&
4537         if ($op->flags & OPf_STACKED) {
4538             return $prefix . $amper . $kid . "(" . $args . ")";
4539         } else {
4540             return $prefix . $amper. $kid;
4541         }
4542     } else {
4543         # It's a syntax error to call CORE::GLOBAL::foo with a prefix,
4544         # so it must have been translated from a keyword call. Translate
4545         # it back.
4546         $kid =~ s/^CORE::GLOBAL:://;
4547
4548         my $dproto = defined($proto) ? $proto : "undefined";
4549         my $scalar_proto = $dproto =~ /^;*(?:[\$*_+]|\\.|\\\[[^]]\])\z/;
4550         if (!$declared) {
4551             return "$kid(" . $args . ")";
4552         } elsif ($dproto =~ /^\s*\z/) {
4553             return $kid;
4554         } elsif ($scalar_proto and is_scalar($exprs[0])) {
4555             # is_scalar is an excessively conservative test here:
4556             # really, we should be comparing to the precedence of the
4557             # top operator of $exprs[0] (ala unop()), but that would
4558             # take some major code restructuring to do right.
4559             return $self->maybe_parens_func($kid, $args, $cx, 16);
4560         } elsif (not $scalar_proto and defined($proto) || $simple) { #'
4561             return $self->maybe_parens_func($kid, $args, $cx, 5);
4562         } else {
4563             return "$kid(" . $args . ")";
4564         }
4565     }
4566 }
4567
4568 sub pp_enterwrite { unop(@_, "write") }
4569
4570 # escape things that cause interpolation in double quotes,
4571 # but not character escapes
4572 sub uninterp {
4573     my($str) = @_;
4574     $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
4575     return $str;
4576 }
4577
4578 {
4579 my $bal;
4580 BEGIN {
4581     use re "eval";
4582     # Matches any string which is balanced with respect to {braces}
4583     $bal = qr(
4584       (?:
4585         [^\\{}]
4586       | \\\\
4587       | \\[{}]
4588       | \{(??{$bal})\}
4589       )*
4590     )x;
4591 }
4592
4593 # the same, but treat $|, $), $( and $ at the end of the string differently
4594 # and leave comments unmangled for the sake of /x and (?x).
4595 sub re_uninterp {
4596     my($str) = @_;
4597
4598     $str =~ s/
4599           ( ^|\G                  # $1
4600           | [^\\]
4601           )
4602
4603           (                       # $2
4604             (?:\\\\)*
4605           )
4606
4607           (                       # $3
4608             ( \(\?\??\{$bal\}\)   # $4  (skip over (?{}) and (??{}) blocks)
4609             | \#[^\n]*            #     (skip over comments)
4610             )
4611           | [\$\@]
4612             (?!\||\)|\(|$|\s)
4613           | \\[uUlLQE]
4614           )
4615
4616         /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
4617
4618     return $str;
4619 }
4620 }
4621
4622 # character escapes, but not delimiters that might need to be escaped
4623 sub escape_str { # ASCII, UTF8
4624     my($str) = @_;
4625     $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
4626     $str =~ s/\a/\\a/g;
4627 #    $str =~ s/\cH/\\b/g; # \b means something different in a regex; and \cH
4628                           # isn't a backspace in EBCDIC
4629     $str =~ s/\t/\\t/g;
4630     $str =~ s/\n/\\n/g;
4631     $str =~ s/\e/\\e/g;
4632     $str =~ s/\f/\\f/g;
4633     $str =~ s/\r/\\r/g;
4634     $str =~ s/([\cA-\cZ])/'\\c' . $unctrl{$1}/ge;
4635     $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/age;
4636     return $str;
4637 }
4638
4639 # For regexes.  Leave whitespace unmangled in case of /x or (?x).
4640 sub escape_re {
4641     my($str) = @_;
4642     $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
4643     $str =~ s/([[:^print:]])/
4644         ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/age;
4645     $str =~ s/\n/\n\f/g;
4646     return $str;
4647 }
4648
4649 # Don't do this for regexen
4650 sub unback {
4651     my($str) = @_;
4652     $str =~ s/\\/\\\\/g;
4653     return $str;
4654 }
4655
4656 # Remove backslashes which precede literal control characters,
4657 # to avoid creating ambiguity when we escape the latter.
4658 sub re_unback {
4659     my($str) = @_;
4660
4661     # the insane complexity here is due to the behaviour of "\c\"
4662     $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
4663     return $str;
4664 }
4665
4666 sub balanced_delim {
4667     my($str) = @_;
4668     my @str = split //, $str;
4669     my($ar, $open, $close, $fail, $c, $cnt, $last_bs);
4670     for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
4671         ($open, $close) = @$ar;
4672         $fail = 0; $cnt = 0; $last_bs = 0;
4673         for $c (@str) {
4674             if ($c eq $open) {
4675                 $fail = 1 if $last_bs;
4676                 $cnt++;
4677             } elsif ($c eq $close) {
4678                 $fail = 1 if $last_bs;
4679                 $cnt--;
4680                 if ($cnt < 0) {
4681                     # qq()() isn't ")("
4682                     $fail = 1;
4683                     last;
4684                 }
4685             }
4686             $last_bs = $c eq '\\';
4687         }
4688         $fail = 1 if $cnt != 0;
4689         return ($open, "$open$str$close") if not $fail;
4690     }
4691     return ("", $str);
4692 }
4693
4694 sub single_delim {
4695     my($q, $default, $str, $self) = @_;
4696     return "$default$str$default" if $default and index($str, $default) == -1;
4697     my $coreq = $self->keyword($q); # maybe CORE::q
4698     if ($q ne 'qr') {
4699         (my $succeed, $str) = balanced_delim($str);
4700         return "$coreq$str" if $succeed;
4701     }
4702     for my $delim ('/', '"', '#') {
4703         return "$coreq$delim" . $str . $delim if index($str, $delim) == -1;
4704     }
4705     if ($default) {
4706         $str =~ s/$default/\\$default/g;
4707         return "$default$str$default";
4708     } else {
4709         $str =~ s[/][\\/]g;
4710         return "$coreq/$str/";
4711     }
4712 }
4713
4714 my $max_prec;
4715 BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
4716
4717 # Split a floating point number into an integer mantissa and a binary
4718 # exponent. Assumes you've already made sure the number isn't zero or
4719 # some weird infinity or NaN.
4720 sub split_float {
4721     my($f) = @_;
4722     my $exponent = 0;
4723     if ($f == int($f)) {
4724         while ($f % 2 == 0) {
4725             $f /= 2;
4726             $exponent++;
4727         }
4728     } else {
4729         while ($f != int($f)) {
4730             $f *= 2;
4731             $exponent--;
4732         }
4733     }
4734     my $mantissa = sprintf("%.0f", $f);
4735     return ($mantissa, $exponent);
4736 }
4737
4738 sub const {
4739     my $self = shift;
4740     my($sv, $cx) = @_;
4741     if ($self->{'use_dumper'}) {
4742         return $self->const_dumper($sv, $cx);
4743     }
4744     if (class($sv) eq "SPECIAL") {
4745         # sv_undef, sv_yes, sv_no
4746         return $$sv == 3 ? $self->maybe_parens("!1", $cx, 21)
4747                          : ('undef', '1')[$$sv-1];
4748     }
4749     if (class($sv) eq "NULL") {
4750        return 'undef';
4751     }
4752     # convert a version object into the "v1.2.3" string in its V magic
4753     if ($sv->FLAGS & SVs_RMG) {
4754         for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
4755             return $mg->PTR if $mg->TYPE eq 'V';
4756         }
4757     }
4758
4759     if ($sv->FLAGS & SVf_IOK) {
4760         my $str = $sv->int_value;
4761         $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
4762         return $str;
4763     } elsif ($sv->FLAGS & SVf_NOK) {
4764         my $nv = $sv->NV;
4765         if ($nv == 0) {
4766             if (pack("F", $nv) eq pack("F", 0)) {
4767                 # positive zero
4768                 return "0";
4769             } else {
4770                 # negative zero
4771                 return $self->maybe_parens("-.0", $cx, 21);
4772             }
4773         } elsif (1/$nv == 0) {
4774             if ($nv > 0) {
4775                 # positive infinity
4776                 return $self->maybe_parens("9**9**9", $cx, 22);
4777             } else {
4778                 # negative infinity
4779                 return $self->maybe_parens("-9**9**9", $cx, 21);
4780             }
4781         } elsif ($nv != $nv) {
4782             # NaN
4783             if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
4784                 # the normal kind
4785                 return "sin(9**9**9)";
4786             } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
4787                 # the inverted kind
4788                 return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
4789             } else {
4790                 # some other kind
4791                 my $hex = unpack("h*", pack("F", $nv));
4792                 return qq'unpack("F", pack("h*", "$hex"))';
4793             }
4794         }
4795         # first, try the default stringification
4796         my $str = "$nv";
4797         if ($str != $nv) {
4798             # failing that, try using more precision
4799             $str = sprintf("%.${max_prec}g", $nv);
4800 #           if (pack("F", $str) ne pack("F", $nv)) {
4801             if ($str != $nv) {
4802                 # not representable in decimal with whatever sprintf()
4803                 # and atof() Perl is using here.
4804                 my($mant, $exp) = split_float($nv);
4805                 return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
4806             }
4807         }
4808         $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
4809         return $str;
4810     } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
4811         my $ref = $sv->RV;
4812         my $class = class($ref);
4813         if ($class eq "AV") {
4814             return "[" . $self->list_const(2, $ref->ARRAY) . "]";
4815         } elsif ($class eq "HV") {
4816             my %hash = $ref->ARRAY;
4817             my @elts;
4818             for my $k (sort keys %hash) {
4819                 push @elts, "$k => " . $self->const($hash{$k}, 6);
4820             }
4821             return "{" . join(", ", @elts) . "}";
4822         } elsif ($class eq "CV") {
4823             BEGIN {
4824                 if ($] > 5.0150051) {
4825                     require overloading;
4826                     unimport overloading;
4827                 }
4828             }
4829             if ($] > 5.0150051 && $self->{curcv} &&
4830                  $self->{curcv}->object_2svref == $ref->object_2svref) {
4831                 return $self->keyword("__SUB__");
4832             }
4833             return "sub " . $self->deparse_sub($ref);
4834         }
4835         if ($class ne 'SPECIAL' and $ref->FLAGS & SVs_SMG) {
4836             for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
4837                 if ($mg->TYPE eq 'r') {
4838                     my $re = re_uninterp(escape_re(re_unback($mg->precomp)));
4839                     return single_delim("qr", "", $re, $self);
4840                 }
4841             }
4842         }
4843
4844         my $const = $self->const($ref, 20);
4845         if ($self->{in_subst_repl} && $const =~ /^[0-9]/) {
4846             $const = "($const)";
4847         }
4848         return $self->maybe_parens("\\$const", $cx, 20);
4849     } elsif ($sv->FLAGS & SVf_POK) {
4850         my $str = $sv->PV;
4851         if ($str =~ /[[:^print:]]/a) {
4852             return single_delim("qq", '"',
4853                                  uninterp(escape_str unback $str), $self);
4854         } else {
4855             return single_delim("q", "'", unback($str), $self);
4856         }
4857     } else {
4858         return "undef";
4859     }
4860 }
4861
4862 sub const_dumper {
4863     my $self = shift;
4864     my($sv, $cx) = @_;
4865     my $ref = $sv->object_2svref();
4866     my $dumper = Data::Dumper->new([$$ref], ['$v']);
4867     $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
4868     my $str = $dumper->Dump();
4869     if ($str =~ /^\$v/) {
4870         return '${my ' . $str . ' \$v}';
4871     } else {
4872         return $str;
4873     }
4874 }
4875
4876 sub const_sv {
4877     my $self = shift;
4878     my $op = shift;
4879     my $sv = $op->sv;
4880     # the constant could be in the pad (under useithreads)
4881     $sv = $self->padval($op->targ) unless $$sv;
4882     return $sv;
4883 }
4884
4885 sub meth_sv {
4886     my $self = shift;
4887     my $op = shift;
4888     my $sv = $op->meth_sv;
4889     # the constant could be in the pad (under useithreads)
4890     $sv = $self->padval($op->targ) unless $$sv;
4891     return $sv;
4892 }
4893
4894 sub meth_rclass_sv {
4895     my $self = shift;
4896     my $op = shift;
4897     my $sv = $op->rclass;
4898     # the constant could be in the pad (under useithreads)
4899     $sv = $self->padval($sv) unless ref $sv;
4900     return $sv;
4901 }
4902
4903 sub pp_const {
4904     my $self = shift;
4905     my($op, $cx) = @_;
4906     if ($op->private & OPpCONST_ARYBASE) {
4907         return '$[';
4908     }
4909 #    if ($op->private & OPpCONST_BARE) { # trouble with '=>' autoquoting
4910 #       return $self->const_sv($op)->PV;
4911 #    }
4912     my $sv = $self->const_sv($op);
4913     return $self->const($sv, $cx);
4914 }
4915
4916 sub dq {
4917     my $self = shift;
4918     my $op = shift;
4919     my $type = $op->name;
4920     if ($type eq "const") {
4921         return '$[' if $op->private & OPpCONST_ARYBASE;
4922         return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
4923     } elsif ($type eq "concat") {
4924         my $first = $self->dq($op->first);
4925         my $last  = $self->dq($op->last);
4926
4927         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
4928         ($last =~ /^[A-Z\\\^\[\]_?]/ &&
4929             $first =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
4930             || ($last =~ /^[:'{\[\w_]/ && #'
4931                 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
4932
4933         return $first . $last;
4934     } elsif ($type eq "uc") {
4935         return '\U' . $self->dq($op->first->sibling) . '\E';
4936     } elsif ($type eq "lc") {
4937         return '\L' . $self->dq($op->first->sibling) . '\E';
4938     } elsif ($type eq "ucfirst") {
4939         return '\u' . $self->dq($op->first->sibling);
4940     } elsif ($type eq "lcfirst") {
4941         return '\l' . $self->dq($op->first->sibling);
4942     } elsif ($type eq "quotemeta") {
4943         return '\Q' . $self->dq($op->first->sibling) . '\E';
4944     } elsif ($type eq "fc") {
4945         return '\F' . $self->dq($op->first->sibling) . '\E';
4946     } elsif ($type eq "join") {
4947         return $self->deparse($op->last, 26); # was join($", @ary)
4948     } else {
4949         return $self->deparse($op, 26);
4950     }
4951 }
4952
4953 sub pp_backtick {
4954     my $self = shift;
4955     my($op, $cx) = @_;
4956     # skip pushmark if it exists (readpipe() vs ``)
4957     my $child = $op->first->sibling->isa('B::NULL')
4958         ? $op->first : $op->first->sibling;
4959     if ($self->pure_string($child)) {
4960         return single_delim("qx", '`', $self->dq($child, 1), $self);
4961     }
4962     unop($self, @_, "readpipe");
4963 }
4964
4965 sub dquote {
4966     my $self = shift;
4967     my($op, $cx) = @_;
4968     my $kid = $op->first->sibling; # skip ex-stringify, pushmark
4969     return $self->deparse($kid, $cx) if $self->{'unquote'};
4970     $self->maybe_targmy($kid, $cx,
4971                         sub {single_delim("qq", '"', $self->dq($_[1]),
4972                                            $self)});
4973 }
4974
4975 # OP_STRINGIFY is a listop, but it only ever has one arg
4976 sub pp_stringify {
4977     my ($self, $op, $cx) = @_;
4978     my $kid = $op->first->sibling;
4979     while ($kid->name eq 'null' && !null($kid->first)) {
4980         $kid = $kid->first;
4981     }
4982     if ($kid->name =~ /^(?:const|padsv|rv2sv|av2arylen|gvsv|multideref
4983                           |aelemfast(?:_lex)?|[ah]elem|join|concat)\z/x) {
4984         maybe_targmy(@_, \&dquote);
4985     }
4986     else {
4987         # Actually an optimised join.
4988         my $result = listop(@_,"join");
4989         $result =~ s/join([( ])/join$1$self->{'ex_const'}, /;
4990         $result;
4991     }
4992 }
4993
4994 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
4995 # note that tr(from)/to/ is OK, but not tr/from/(to)
4996 sub double_delim {
4997     my($from, $to) = @_;
4998     my($succeed, $delim);
4999     if ($from !~ m[/] and $to !~ m[/]) {
5000         return "/$from/$to/";
5001     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
5002         if (($succeed, $to) = balanced_delim($to) and $succeed) {
5003             return "$from$to";
5004         } else {
5005             for $delim ('/', '"', '#') { # note no "'" -- s''' is special
5006                 return "$from$delim$to$delim" if index($to, $delim) == -1;
5007             }
5008             $to =~ s[/][\\/]g;
5009             return "$from/$to/";
5010         }
5011     } else {
5012         for $delim ('/', '"', '#') { # note no '
5013             return "$delim$from$delim$to$delim"
5014                 if index($to . $from, $delim) == -1;
5015         }
5016         $from =~ s[/][\\/]g;
5017         $to =~ s[/][\\/]g;
5018         return "/$from/$to/";
5019     }
5020 }
5021
5022 # Only used by tr///, so backslashes hyphens
5023 sub pchr { # ASCII
5024     my($n) = @_;
5025     if ($n == ord '\\') {
5026         return '\\\\';
5027     } elsif ($n == ord "-") {
5028         return "\\-";
5029     } elsif (utf8::native_to_unicode($n) >= utf8::native_to_unicode(ord(' '))
5030              and utf8::native_to_unicode($n) <= utf8::native_to_unicode(ord('~')))
5031     {
5032         # I'm presuming a regex is not ok here, otherwise we could have used
5033         # /[[:print:]]/a to get here
5034         return chr($n);
5035     } elsif ($n == ord "\a") {
5036         return '\\a';
5037     } elsif ($n == ord "\b") {
5038         return '\\b';
5039     } elsif ($n == ord "\t") {
5040         return '\\t';
5041     } elsif ($n == ord "\n") {
5042         return '\\n';
5043     } elsif ($n == ord "\e") {
5044         return '\\e';
5045     } elsif ($n == ord "\f") {
5046         return '\\f';
5047     } elsif ($n == ord "\r") {
5048         return '\\r';
5049     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
5050         return '\\c' . unctrl{chr $n};
5051     } else {
5052 #       return '\x' . sprintf("%02x", $n);
5053         return '\\' . sprintf("%03o", $n);
5054     }
5055 }
5056
5057 sub collapse {
5058     my(@chars) = @_;
5059     my($str, $c, $tr) = ("");
5060     for ($c = 0; $c < @chars; $c++) {
5061         $tr = $chars[$c];
5062         $str .= pchr($tr);
5063         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
5064             $chars[$c + 2] == $tr + 2)
5065         {
5066             for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
5067               {}
5068             $str .= "-";
5069             $str .= pchr($chars[$c]);
5070         }
5071     }
5072     return $str;
5073 }
5074
5075 sub tr_decode_byte {
5076     my($table, $flags) = @_;
5077     my(@table) = unpack("s*", $table);
5078     splice @table, 0x100, 1;   # Number of subsequent elements
5079     my($c, $tr, @from, @to, @delfrom, $delhyphen);
5080     if ($table[ord "-"] != -1 and
5081         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
5082     {
5083         $tr = $table[ord "-"];
5084         $table[ord "-"] = -1;
5085         if ($tr >= 0) {
5086             @from = ord("-");
5087             @to = $tr;
5088         } else { # -2 ==> delete
5089             $delhyphen = 1;
5090         }
5091     }
5092     for ($c = 0; $c < @table; $c++) {
5093         $tr = $table[$c];
5094         if ($tr >= 0) {
5095             push @from, $c; push @to, $tr;
5096         } elsif ($tr == -2) {
5097             push @delfrom, $c;
5098         }
5099     }
5100     @from = (@from, @delfrom);
5101     if ($flags & OPpTRANS_COMPLEMENT) {
5102         my @newfrom = ();
5103         my %from;
5104         @from{@from} = (1) x @from;
5105         for ($c = 0; $c < 256; $c++) {
5106             push @newfrom, $c unless $from{$c};
5107         }
5108         @from = @newfrom;
5109     }
5110     unless ($flags & OPpTRANS_DELETE || !@to) {
5111         pop @to while $#to and $to[$#to] == $to[$#to -1];
5112     }
5113     my($from, $to);
5114     $from = collapse(@from);
5115     $to = collapse(@to);
5116     $from .= "-" if $delhyphen;
5117     return ($from, $to);
5118 }
5119
5120 sub tr_chr {
5121     my $x = shift;
5122     if ($x == ord "-") {
5123         return "\\-";
5124     } elsif ($x == ord "\\") {
5125         return "\\\\";
5126     } else {
5127         return chr $x;
5128     }
5129 }
5130
5131 # XXX This doesn't yet handle all cases correctly either
5132
5133 sub tr_decode_utf8 {
5134     my($swash_hv, $flags) = @_;
5135     my %swash = $swash_hv->ARRAY;
5136     my $final = undef;
5137     $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
5138     my $none = $swash{"NONE"}->IV;
5139     my $extra = $none + 1;
5140     my(@from, @delfrom, @to);
5141     my $line;
5142     foreach $line (split /\n/, $swash{'LIST'}->PV) {
5143         my($min, $max, $result) = split(/\t/, $line);
5144         $min = hex $min;
5145         if (length $max) {
5146             $max = hex $max;
5147         } else {
5148             $max = $min;
5149         }
5150         $result = hex $result;
5151         if ($result == $extra) {
5152             push @delfrom, [$min, $max];
5153         } else {
5154             push @from, [$min, $max];
5155             push @to, [$result, $result + $max - $min];
5156         }
5157     }
5158     for my $i (0 .. $#from) {
5159         if ($from[$i][0] == ord '-') {
5160             unshift @from, splice(@from, $i, 1);
5161             unshift @to, splice(@to, $i, 1);
5162             last;
5163         } elsif ($from[$i][1] == ord '-') {
5164             $from[$i][1]--;
5165             $to[$i][1]--;
5166             unshift @from, ord '-';
5167             unshift @to, ord '-';
5168             last;
5169         }
5170     }
5171     for my $i (0 .. $#delfrom) {
5172         if ($delfrom[$i][0] == ord '-') {
5173             push @delfrom, splice(@delfrom, $i, 1);
5174             last;
5175         } elsif ($delfrom[$i][1] == ord '-') {
5176             $delfrom[$i][1]--;
5177             push @delfrom, ord '-';
5178             last;
5179         }
5180     }
5181     if (defined $final and $to[$#to][1] != $final) {
5182         push @to, [$final, $final];
5183     }
5184     push @from, @delfrom;
5185     if ($flags & OPpTRANS_COMPLEMENT) {
5186         my @newfrom;
5187         my $next = 0;
5188         for my $i (0 .. $#from) {
5189             push @newfrom, [$next, $from[$i][0] - 1];
5190             $next = $from[$i][1] + 1;
5191         }
5192         @from = ();
5193         for my $range (@newfrom) {
5194             if ($range->[0] <= $range->[1]) {
5195                 push @from, $range;
5196             }
5197         }
5198     }
5199     my($from, $to, $diff);
5200     for my $chunk (@from) {
5201         $diff = $chunk->[1] - $chunk->[0];
5202         if ($diff > 1) {
5203             $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
5204         } elsif ($diff == 1) {
5205             $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
5206         } else {
5207             $from .= tr_chr($chunk->[0]);
5208         }
5209     }
5210     for my $chunk (@to) {
5211         $diff = $chunk->[1] - $chunk->[0];
5212         if ($diff > 1) {
5213             $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
5214         } elsif ($diff == 1) {
5215             $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
5216         } else {
5217             $to .= tr_chr($chunk->[0]);
5218         }
5219     }
5220     #$final = sprintf("%04x", $final) if defined $final;
5221     #$none = sprintf("%04x", $none) if defined $none;
5222     #$extra = sprintf("%04x", $extra) if defined $extra;
5223     #print STDERR "final: $final\n none: $none\nextra: $extra\n";
5224     #print STDERR $swash{'LIST'}->PV;
5225     return (escape_str($from), escape_str($to));
5226 }
5227
5228 sub pp_trans {
5229     my $self = shift;
5230     my($op, $cx, $morflags) = @_;
5231     my($from, $to);
5232     my $class = class($op);
5233     my $priv_flags = $op->private;
5234     if ($class eq "PVOP") {
5235         ($from, $to) = tr_decode_byte($op->pv, $priv_flags);
5236     } elsif ($class eq "PADOP") {
5237         ($from, $to)
5238           = tr_decode_utf8($self->padval($op->padix)->RV, $priv_flags);
5239     } else { # class($op) eq "SVOP"
5240         ($from, $to) = tr_decode_utf8($op->sv->RV, $priv_flags);
5241     }
5242     my $flags = "";
5243     $flags .= "c" if $priv_flags & OPpTRANS_COMPLEMENT;
5244     $flags .= "d" if $priv_flags & OPpTRANS_DELETE;
5245     $to = "" if $from eq $to and $flags eq "";
5246     $flags .= "s" if $priv_flags & OPpTRANS_SQUASH;
5247     $flags .= $morflags if defined $morflags;
5248     my $ret = $self->keyword("tr") . double_delim($from, $to) . $flags;
5249     if (my $targ = $op->targ) {
5250         return $self->maybe_parens($self->padname($targ) . " =~ $ret",
5251                                    $cx, 20);
5252     }
5253     return $ret;
5254 }
5255
5256 sub pp_transr { push @_, 'r'; goto &pp_trans }
5257
5258 sub re_dq_disambiguate {
5259     my ($first, $last) = @_;
5260     # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
5261     ($last =~ /^[A-Z\\\^\[\]_?]/ &&
5262         $first =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
5263         || ($last =~ /^[{\[\w_]/ &&
5264             $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
5265     return $first . $last;
5266 }
5267
5268 # Like dq(), but different
5269 sub re_dq {
5270     my $self = shift;
5271     my ($op) = @_;
5272
5273     my $type = $op->name;
5274     if ($type eq "const") {
5275         return '$[' if $op->private & OPpCONST_ARYBASE;
5276         my $unbacked = re_unback($self->const_sv($op)->as_string);
5277         return re_uninterp(escape_re($unbacked));
5278     } elsif ($type eq "concat") {
5279         my $first = $self->re_dq($op->first);
5280         my $last  = $self->re_dq($op->last);
5281         return re_dq_disambiguate($first, $last);
5282     } elsif ($type eq "uc") {
5283         return '\U' . $self->re_dq($op->first->sibling) . '\E';
5284     } elsif ($type eq "lc") {
5285         return '\L' . $self->re_dq($op->first->sibling) . '\E';
5286     } elsif ($type eq "ucfirst") {
5287         return '\u' . $self->re_dq($op->first->sibling);
5288     } elsif ($type eq "lcfirst") {
5289         return '\l' . $self->re_dq($op->first->sibling);
5290     } elsif ($type eq "quotemeta") {
5291         return '\Q' . $self->re_dq($op->first->sibling) . '\E';
5292     } elsif ($type eq "fc") {
5293         return '\F' . $self->re_dq($op->first->sibling) . '\E';
5294     } elsif ($type eq "join") {
5295         return $self->deparse($op->last, 26); # was join($", @ary)
5296     } else {
5297         my $ret = $self->deparse($op, 26);
5298         $ret =~ s/^\$([(|)])\z/\${$1}/ # $( $| $) need braces
5299         or $ret =~ s/^\@([-+])\z/\@{$1}/; # @- @+ need braces
5300         return $ret;
5301     }
5302 }
5303
5304 sub pure_string {
5305     my ($self, $op) = @_;
5306     return 0 if null $op;
5307     my $type = $op->name;
5308
5309     if ($type eq 'const' || $type eq 'av2arylen') {
5310         return 1;
5311     }
5312     elsif ($type =~ /^(?:[ul]c(first)?|fc)$/ || $type eq 'quotemeta') {
5313         return $self->pure_string($op->first->sibling);
5314     }
5315     elsif ($type eq 'join') {
5316         my $join_op = $op->first->sibling;  # Skip pushmark
5317         return 0 unless $join_op->name eq 'null' && $join_op->targ == OP_RV2SV;
5318
5319         my $gvop = $join_op->first;
5320         return 0 unless $gvop->name eq 'gvsv';
5321         return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
5322
5323         return 0 unless ${$join_op->sibling} eq ${$op->last};
5324         return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
5325     }
5326     elsif ($type eq 'concat') {
5327         return $self->pure_string($op->first)
5328             && $self->pure_string($op->last);
5329     }
5330     elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
5331         return 1;
5332     }
5333     elsif ($type eq "null" and $op->can('first') and not null $op->first) {
5334         my $first = $op->first;
5335
5336         return 1 if $first->name eq "multideref";
5337         return 1 if $first->name eq "aelemfast_lex";
5338
5339         if (    $first->name eq "null"
5340             and $first->can('first')
5341             and not null $first->first
5342             and $first->first->name eq "aelemfast"
5343            )
5344         {
5345             return 1;
5346         }
5347     }
5348
5349     return 0;
5350 }
5351
5352 sub code_list {
5353     my ($self,$op,$cv) = @_;
5354
5355     # localise stuff relating to the current sub
5356     $cv and
5357         local($self->{'curcv'}) = $cv,
5358         local($self->{'curcvlex'}),
5359         local(@$self{qw'curstash warnings hints hinthash curcop'})
5360             = @$self{qw'curstash warnings hints hinthash curcop'};
5361
5362     my $re;
5363     for ($op = $op->first->sibling; !null($op); $op = $op->sibling) {
5364         if ($op->name eq 'null' and $op->flags & OPf_SPECIAL) {
5365             my $scope = $op->first;
5366             # 0 context (last arg to scopeop) means statement context, so
5367             # the contents of the block will not be wrapped in do{...}.
5368             my $block = scopeop($scope->first->name eq "enter", $self,
5369                                 $scope, 0);
5370             # next op is the source code of the block
5371             $op = $op->sibling;
5372             $re .= ($self->const_sv($op)->PV =~ m|^(\(\?\??\{)|)[0];
5373             my $multiline = $block =~ /\n/;
5374             $re .= $multiline ? "\n\t" : ' ';
5375             $re .= $block;
5376             $re .= $multiline ? "\n\b})" : " })";
5377         } else {
5378             $re = re_dq_disambiguate($re, $self->re_dq($op));
5379         }
5380     }
5381     $re;
5382 }
5383
5384 sub regcomp {
5385     my $self = shift;
5386     my($op, $cx) = @_;
5387     my $kid = $op->first;
5388     $kid = $kid->first if $kid->name eq "regcmaybe";
5389     $kid = $kid->first if $kid->name eq "regcreset";
5390     my $kname = $kid->name;
5391     if ($kname eq "null" and !null($kid->first)
5392         and $kid->first->name eq 'pushmark')
5393     {
5394         my $str = '';
5395         $kid = $kid->first->sibling;
5396         while (!null($kid)) {
5397             my $first = $str;
5398             my $last = $self->re_dq($kid);
5399             $str = re_dq_disambiguate($first, $last);
5400             $kid = $kid->sibling;
5401         }
5402         return $str, 1;
5403     }
5404
5405     return ($self->re_dq($kid), 1)
5406         if $kname =~ /^(?:rv2|pad)av/ or $self->pure_string($kid);
5407     return ($self->deparse($kid, $cx), 0);
5408 }
5409
5410 sub pp_regcomp {
5411     my ($self, $op, $cx) = @_;
5412     return (($self->regcomp($op, $cx, 0))[0]);
5413 }
5414
5415 sub re_flags {
5416     my ($self, $op) = @_;
5417     my $flags = '';
5418     my $pmflags = $op->pmflags;
5419     if (!$pmflags) {
5420         my $re = $op->pmregexp;
5421         if ($$re) {
5422             $pmflags = $re->compflags;
5423         }
5424     }
5425     $flags .= "g" if $pmflags & PMf_GLOBAL;
5426     $flags .= "i" if $pmflags & PMf_FOLD;
5427     $flags .= "m" if $pmflags & PMf_MULTILINE;
5428     $flags .= "o" if $pmflags & PMf_KEEP;
5429     $flags .= "s" if $pmflags & PMf_SINGLELINE;
5430     $flags .= "x" if $pmflags & PMf_EXTENDED;
5431     $flags .= "x" if $pmflags & PMf_EXTENDED_MORE;
5432     $flags .= "p" if $pmflags & PMf_KEEPCOPY;
5433     $flags .= "n" if $pmflags & PMf_NOCAPTURE;
5434     if (my $charset = $pmflags & PMf_CHARSET) {
5435         # Hardcoding this is fragile, but B does not yet export the
5436         # constants we need.
5437         $flags .= qw(d l u a aa)[$charset >> 7]
5438     }
5439     # The /d flag is indicated by 0; only show it if necessary.
5440     elsif ($self->{hinthash} and
5441              $self->{hinthash}{reflags_charset}
5442             || $self->{hinthash}{feature_unicode}
5443         or $self->{hints} & $feature::hint_mask
5444           && ($self->{hints} & $feature::hint_mask)
5445                != $feature::hint_mask
5446           && $self->{hints} & $feature::hint_uni8bit
5447     ) {
5448         $flags .= 'd';
5449     }
5450     $flags;
5451 }
5452
5453 # osmic acid -- see osmium tetroxide
5454
5455 my %matchwords;
5456 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
5457     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
5458     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi', 'soup', 'soupmix');
5459
5460 # When deparsing a regular expression with code blocks, we have to look in
5461 # various places to find the blocks.
5462 #
5463 # For qr/(?{...})/ without interpolation, the CV is under $qr->qr_anoncv
5464 # and the code list (list of blocks and constants, maybe vars) is under
5465 # $cv->ROOT->first->code_list:
5466 #   ./perl -Ilib -MB -e 'use O "Concise", B::svref_2object(sub {qr/(?{die})/})->ROOT->first->first->sibling->pmregexp->qr_anoncv->object_2svref'
5467 #
5468 # For qr/$a(?{...})/ with interpolation, the code list is more accessible,
5469 # under $pmop->code_list, but the $cv is something you have to dig for in
5470 # the regcomp op’s kids:
5471 #   ./perl -Ilib -mO=Concise -e 'qr/$a(?{die})/'
5472 #
5473 # For m// and split //, things are much simpler.  There is no CV.  The code
5474 # list is under $pmop->code_list.
5475
5476 sub matchop {
5477     my $self = shift;
5478     my($op, $cx, $name, $delim) = @_;
5479     my $kid = $op->first;
5480     my ($binop, $var, $re) = ("", "", "");
5481     if ($op->flags & OPf_STACKED) {
5482         $binop = 1;
5483         $var = $self->deparse($kid, 20);
5484         $kid = $kid->sibling;
5485     }
5486            # not $name; $name will be 'm' for both match and split
5487     elsif ($op->name eq 'match' and my $targ = $op->targ) {
5488         $binop = 1;
5489         $var = $self->padname($targ);
5490     }
5491     my $quote = 1;
5492     my $pmflags = $op->pmflags;
5493     my $rhs_bound_to_defsv;
5494     my ($cv, $bregexp);
5495     my $have_kid = !null $kid;
5496     # Check for code blocks first
5497     if (not null my $code_list = $op->code_list) {
5498         $re = $self->code_list($code_list,
5499                                $op->name eq 'qr'
5500                                    ? $self->padval(
5501                                          $kid->first   # ex-list
5502                                              ->first   #   pushmark
5503                                              ->sibling #   entersub
5504                                              ->first   #     ex-list
5505                                              ->first   #       pushmark
5506                                              ->sibling #       srefgen
5507                                              ->first   #         ex-list
5508                                              ->first   #           anoncode
5509                                              ->targ
5510                                      )
5511                                    : undef);
5512     } elsif (${$bregexp = $op->pmregexp} && ${$cv = $bregexp->qr_anoncv}) {
5513         my $patop = $cv->ROOT      # leavesub
5514                        ->first     #   qr
5515                        ->code_list;#     list
5516         $re = $self->code_list($patop, $cv);
5517     } elsif (!$have_kid) {
5518         $re = re_uninterp(escape_re(re_unback($op->precomp)));
5519     } elsif ($kid->name ne 'regcomp') {
5520         carp("found ".$kid->name." where regcomp expected");
5521     } else {
5522         ($re, $quote) = $self->regcomp($kid, 21);
5523     }
5524     if ($have_kid and $kid->name eq 'regcomp') {
5525         my $matchop = $kid->first;
5526         if ($matchop->name eq 'regcreset') {
5527             $matchop = $matchop->first;
5528         }
5529         if ($matchop->name =~ /^(?:match|transr?|subst)\z/
5530            && $matchop->flags & OPf_SPECIAL) {
5531             $rhs_bound_to_defsv = 1;
5532         }
5533     }
5534     my $flags = "";
5535     $flags .= "c" if $pmflags & PMf_CONTINUE;
5536     $flags .= $self->re_flags($op);
5537     $flags = join '', sort split //, $flags;
5538     $flags = $matchwords{$flags} if $matchwords{$flags};
5539     if ($pmflags & PMf_ONCE) { # only one kind of delimiter works here
5540         $re =~ s/\?/\\?/g;
5541         $re = $self->keyword("m") . "?$re?";     # explicit 'm' is required
5542     } elsif ($quote) {
5543         $re = single_delim($name, $delim, $re, $self);
5544     }
5545     $re = $re . $flags if $quote;
5546     if ($binop) {
5547         return
5548          $self->maybe_parens(
5549           $rhs_bound_to_defsv
5550            ? "$var =~ (\$_ =~ $re)"
5551            : "$var =~ $re",
5552           $cx, 20
5553          );
5554     } else {
5555         return $re;
5556     }
5557 }
5558
5559 sub pp_match { matchop(@_, "m", "/") }
5560 sub pp_pushre { matchop(@_, "m", "/") }
5561 sub pp_qr { matchop(@_, "qr", "") }
5562
5563 sub pp_runcv { unop(@_, "__SUB__"); }
5564
5565 sub pp_split {
5566     maybe_targmy(@_, \&split);
5567 }
5568 sub split {
5569     my $self = shift;
5570     my($op, $cx) = @_;
5571     my($kid, @exprs, $ary, $expr);
5572     $kid = $op->first;
5573
5574     # For our kid (an OP_PUSHRE), pmreplroot is never actually the
5575     # root of a replacement; it's either empty, or abused to point to
5576     # the GV for an array we split into (an optimization to save
5577     # assignment overhead). Depending on whether we're using ithreads,
5578     # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
5579     # figures out for us which it is.
5580     my $replroot = $kid->pmreplroot;
5581     my $gv = 0;
5582     my $stacked = $op->flags & OPf_STACKED;
5583     if (ref($replroot) eq "B::GV") {
5584         $gv = $replroot;
5585     } elsif (!ref($replroot) and $replroot > 0) {
5586         $gv = $self->padval($replroot);
5587     } elsif ($kid->targ) {
5588         $ary = $self->padname($kid->targ)
5589     } elsif ($stacked) {
5590         $ary = $self->deparse($op->last, 7);
5591     }
5592     $ary = $self->maybe_local(@_,
5593                               $self->stash_variable('@',
5594                                                      $self->gv_name($gv),
5595                                                      $cx))
5596         if $gv;
5597
5598     # Skip the last kid when OPf_STACKED is set, since it is the array
5599     # on the left.
5600     for (; !null($stacked ? $kid->sibling : $kid); $kid = $kid->sibling) {
5601         push @exprs, $self->deparse($kid, 6);
5602     }
5603
5604     # handle special case of split(), and split(' ') that compiles to /\s+/
5605     # Under 5.10, the reflags may be undef if the split regexp isn't a constant
5606     # Under 5.17.5-5.17.9, the special flag is on split itself.
5607     $kid = $op->first;
5608     if ( $op->flags & OPf_SPECIAL
5609          or (
5610             $kid->flags & OPf_SPECIAL
5611             and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
5612                              : ($kid->reflags || 0) & RXf_SKIPWHITE()
5613             )
5614          )
5615     ) {
5616         $exprs[0] = "' '";
5617     }
5618
5619     $expr = "split(" . join(", ", @exprs) . ")";
5620     if ($ary) {
5621         return $self->maybe_parens("$ary = $expr", $cx, 7);
5622     } else {
5623         return $expr;
5624     }
5625 }
5626
5627 # oxime -- any of various compounds obtained chiefly by the action of
5628 # hydroxylamine on aldehydes and ketones and characterized by the
5629 # bivalent grouping C=NOH [Webster's Tenth]
5630
5631 my %substwords;
5632 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
5633     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
5634     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
5635     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi', 'rogue',
5636     'sir', 'rise', 'smore', 'more', 'seer', 'rome', 'gore', 'grim', 'grime',
5637     'or', 'rose', 'rosie');
5638
5639 sub pp_subst {
5640     my $self = shift;
5641     my($op, $cx) = @_;
5642     my $kid = $op->first;
5643     my($binop, $var, $re, $repl) = ("", "", "", "");
5644     if ($op->flags & OPf_STACKED) {
5645         $binop = 1;
5646         $var = $self->deparse($kid, 20);
5647         $kid = $kid->sibling;
5648     }
5649     elsif (my $targ = $op->targ) {
5650         $binop = 1;
5651         $var = $self->padname($targ);
5652     }
5653     my $flags = "";
5654     my $pmflags = $op->pmflags;
5655     if (null($op->pmreplroot)) {
5656         $repl = $kid;
5657         $kid = $kid->sibling;
5658     } else {
5659         $repl = $op->pmreplroot->first; # skip substcont
5660     }
5661     while ($repl->name eq "entereval") {
5662             $repl = $repl->first;
5663             $flags .= "e";
5664     }
5665     {
5666         local $self->{in_subst_repl} = 1;
5667         if ($pmflags & PMf_EVAL) {
5668             $repl = $self->deparse($repl->first, 0);
5669         } else {
5670             $repl = $self->dq($repl);
5671         }
5672     }
5673     if (not null my $code_list = $op->code_list) {
5674         $re = $self->code_list($code_list);
5675     } elsif (null $kid) {
5676         $re = re_uninterp(escape_re(re_unback($op->precomp)));
5677     } else {
5678         ($re) = $self->regcomp($kid, 1);
5679     }
5680     $flags .= "r" if $pmflags & PMf_NONDESTRUCT;
5681     $flags .= "e" if $pmflags & PMf_EVAL;
5682     $flags .= $self->re_flags($op);
5683     $flags = join '', sort split //, $flags;
5684     $flags = $substwords{$flags} if $substwords{$flags};
5685     my $core_s = $self->keyword("s"); # maybe CORE::s
5686     if ($binop) {
5687         return $self->maybe_parens("$var =~ $core_s"
5688                                    . double_delim($re, $repl) . $flags,
5689                                    $cx, 20);
5690     } else {
5691         return "$core_s". double_delim($re, $repl) . $flags;
5692     }
5693 }
5694
5695 sub is_lexical_subs {
5696     my (@ops) = shift;
5697     for my $op (@ops) {
5698         return 0 if $op->name !~ /\A(?:introcv|clonecv)\z/;
5699     }
5700     return 1;
5701 }
5702
5703 # Pretend these two ops do not exist.  The perl parser adds them to the
5704 # beginning of any block containing my-sub declarations, whereas we handle
5705 # the subs in pad_subs and next_todo.
5706 *pp_clonecv = *pp_introcv;
5707 sub pp_introcv {
5708     my $self = shift;
5709     my($op, $cx) = @_;
5710     # For now, deparsing doesn't worry about the distinction between introcv
5711     # and clonecv, so pretend this op doesn't exist:
5712     return '';
5713 }
5714
5715 sub pp_padcv {
5716     my $self = shift;
5717     my($op, $cx) = @_;
5718     return $self->padany($op);
5719 }
5720
5721 my %lvref_funnies = (
5722     OPpLVREF_SV, => '$',
5723     OPpLVREF_AV, => '@',
5724     OPpLVREF_HV, => '%',
5725     OPpLVREF_CV, => '&',
5726 );
5727
5728 sub pp_refassign {
5729     my ($self, $op, $cx) = @_;
5730     my $left;
5731     if ($op->private & OPpLVREF_ELEM) {
5732         $left = $op->first->sibling;
5733         $left = maybe_local(@_, elem($self, $left, undef,
5734                                      $left->targ == OP_AELEM
5735                                         ? qw([ ] padav)
5736                                         : qw({ } padhv)));
5737     } elsif ($op->flags & OPf_STACKED) {
5738         $left = maybe_local(@_,
5739                             $lvref_funnies{$op->private & OPpLVREF_TYPE}
5740                           . $self->deparse($op->first->sibling));
5741     } else {
5742         $left = &pp_padsv;
5743     }
5744     my $right = $self->deparse_binop_right($op, $op->first, 7);
5745     return $self->maybe_parens("\\$left = $right", $cx, 7);
5746 }
5747
5748 sub pp_lvref {
5749     my ($self, $op, $cx) = @_;
5750     my $code;
5751     if ($op->private & OPpLVREF_ELEM) {
5752         $code = $op->first->name =~ /av\z/ ? &pp_aelem : &pp_helem;
5753     } elsif ($op->flags & OPf_STACKED) {
5754         $code = maybe_local(@_,
5755                             $lvref_funnies{$op->private & OPpLVREF_TYPE}
5756                           . $self->deparse($op->first));
5757     } else {
5758         $code = &pp_padsv;
5759     }
5760     "\\$code";
5761 }
5762
5763 sub pp_lvrefslice {
5764     my ($self, $op, $cx) = @_;
5765     '\\' . ($op->last->name =~ /av\z/ ? &pp_aslice : &pp_hslice);
5766 }
5767
5768 sub pp_lvavref {
5769     my ($self, $op, $cx) = @_;
5770     '\\(' . ($op->flags & OPf_STACKED
5771                 ? maybe_local(@_, rv2x(@_, "\@"))
5772                 : &pp_padsv)  . ')'
5773 }
5774
5775 1;
5776 __END__
5777
5778 =head1 NAME
5779
5780 B::Deparse - Perl compiler backend to produce perl code
5781
5782 =head1 SYNOPSIS
5783
5784 B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
5785         [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
5786
5787 =head1 DESCRIPTION
5788
5789 B::Deparse is a backend module for the Perl compiler that generates
5790 perl source code, based on the internal compiled structure that perl
5791 itself creates after parsing a program.  The output of B::Deparse won't
5792 be exactly the same as the original source, since perl doesn't keep
5793 track of comments or whitespace, and there isn't a one-to-one
5794 correspondence between perl's syntactical constructions and their
5795 compiled form, but it will often be close.  When you use the B<-p>
5796 option, the output also includes parentheses even when they are not
5797 required by precedence, which can make it easy to see if perl is
5798 parsing your expressions the way you intended.
5799
5800 While B::Deparse goes to some lengths to try to figure out what your
5801 original program was doing, some parts of the language can still trip
5802 it up; it still fails even on some parts of Perl's own test suite.  If
5803 you encounter a failure other than the most common ones described in
5804 the BUGS section below, you can help contribute to B::Deparse's
5805 ongoing development by submitting a bug report with a small
5806 example.
5807
5808 =head1 OPTIONS
5809
5810 As with all compiler backend options, these must follow directly after
5811 the '-MO=Deparse', separated by a comma but not any white space.
5812
5813 =over 4
5814
5815 =item B<-d>
5816
5817 Output data values (when they appear as constants) using Data::Dumper.
5818 Without this option, B::Deparse will use some simple routines of its
5819 own for the same purpose.  Currently, Data::Dumper is better for some
5820 kinds of data (such as complex structures with sharing and
5821 self-reference) while the built-in routines are better for others
5822 (such as odd floating-point values).
5823
5824 =item B<-f>I<FILE>
5825
5826 Normally, B::Deparse deparses the main code of a program, and all the subs
5827 defined in the same file.  To include subs defined in
5828 other files, pass the B<-f> option with the filename.
5829 You can pass the B<-f> option several times, to
5830 include more than one secondary file.  (Most of the time you don't want to
5831 use it at all.)  You can also use this option to include subs which are
5832 defined in the scope of a B<#line> directive with two parameters.
5833
5834 =item B<-l>
5835
5836 Add '#line' declarations to the output based on the line and file
5837 locations of the original code.
5838
5839 =item B<-p>
5840
5841 Print extra parentheses.  Without this option, B::Deparse includes
5842 parentheses in its output only when they are needed, based on the
5843 structure of your program.  With B<-p>, it uses parentheses (almost)
5844 whenever they would be legal.  This can be useful if you are used to
5845 LISP, or if you want to see how perl parses your input.  If you say
5846
5847     if ($var & 0x7f == 65) {print "Gimme an A!"}
5848     print ($which ? $a : $b), "\n";
5849     $name = $ENV{USER} or "Bob";
5850
5851 C<B::Deparse,-p> will print
5852
5853     if (($var & 0)) {
5854         print('Gimme an A!')
5855     };
5856     (print(($which ? $a : $b)), '???');
5857     (($name = $ENV{'USER'}) or '???')
5858
5859 which probably isn't what you intended (the C<'???'> is a sign that
5860 perl optimized away a constant value).
5861
5862 =item B<-P>
5863
5864 Disable prototype checking.  With this option, all function calls are
5865 deparsed as if no prototype was defined for them.  In other words,
5866
5867     perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
5868
5869 will print
5870
5871     sub foo (\@) {
5872         1;
5873     }
5874     &foo(\@x);
5875
5876 making clear how the parameters are actually passed to C<foo>.
5877
5878 =item B<-q>
5879
5880 Expand double-quoted strings into the corresponding combinations of
5881 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join.  For
5882 instance, print
5883
5884     print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
5885
5886 as
5887
5888     print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
5889           . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
5890
5891 Note that the expanded form represents the way perl handles such
5892 constructions internally -- this option actually turns off the reverse
5893 translation that B::Deparse usually does.  On the other hand, note that
5894 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
5895 of $y into a string before doing the assignment.
5896
5897 =item B<-s>I<LETTERS>
5898
5899 Tweak the style of B::Deparse's output.  The letters should follow
5900 directly after the 's', with no space or punctuation.  The following
5901 options are available:
5902
5903 =over 4
5904
5905 =item B<C>
5906
5907 Cuddle C<elsif>, C<else>, and C<continue> blocks.  For example, print
5908
5909     if (...) {
5910          ...
5911     } else {
5912          ...
5913     }
5914
5915 instead of
5916
5917     if (...) {
5918          ...
5919     }
5920     else {
5921          ...
5922     }
5923
5924 The default is not to cuddle.
5925
5926 =item B<i>I<NUMBER>
5927
5928 Indent lines by multiples of I<NUMBER> columns.  The default is 4 columns.
5929
5930 =item B<T>
5931
5932 Use tabs for each 8 columns of indent.  The default is to use only spaces.
5933 For instance, if the style options are B<-si4T>, a line that's indented
5934 3 times will be preceded by one tab and four spaces; if the options were
5935 B<-si8T>, the same line would be preceded by three tabs.
5936
5937 =item B<v>I<STRING>B<.>
5938
5939 Print I<STRING> for the value of a constant that can't be determined
5940 because it was optimized away (mnemonic: this happens when a constant
5941 is used in B<v>oid context).  The end of the string is marked by a period.
5942 The string should be a valid perl expression, generally a constant.
5943 Note that unless it's a number, it probably needs to be quoted, and on
5944 a command line quotes need to be protected from the shell.  Some
5945 conventional values include 0, 1, 42, '', 'foo', and
5946 'Useless use of constant omitted' (which may need to be
5947 B<-sv"'Useless use of constant omitted'.">
5948 or something similar depending on your shell).  The default is '???'.
5949 If you're using B::Deparse on a module or other file that's require'd,
5950 you shouldn't use a value that evaluates to false, since the customary
5951 true constant at the end of a module will be in void context when the
5952 file is compiled as a main program.
5953
5954 =back
5955
5956 =item B<-x>I<LEVEL>
5957
5958 Expand conventional syntax constructions into equivalent ones that expose
5959 their internal operation.  I<LEVEL> should be a digit, with higher values
5960 meaning more expansion.  As with B<-q>, this actually involves turning off
5961 special cases in B::Deparse's normal operations.
5962
5963 If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
5964 while loops with continue blocks; for instance
5965
5966     for ($i = 0; $i < 10; ++$i) {
5967         print $i;
5968     }
5969
5970 turns into
5971
5972     $i = 0;
5973     while ($i < 10) {
5974         print $i;
5975     } continue {
5976         ++$i
5977     }
5978
5979 Note that in a few cases this translation can't be perfectly carried back
5980 into the source code -- if the loop's initializer declares a my variable,
5981 for instance, it won't have the correct scope outside of the loop.
5982
5983 If I<LEVEL> is at least 5, C<use> declarations will be translated into
5984 C<BEGIN> blocks containing calls to C<require> and C<import>; for
5985 instance,
5986
5987     use strict 'refs';
5988
5989 turns into
5990
5991     sub BEGIN {
5992         require strict;
5993         do {
5994             'strict'->import('refs')
5995         };
5996     }
5997
5998 If I<LEVEL> is at least 7, C<if> statements will be translated into
5999 equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
6000
6001     print 'hi' if $nice;
6002     if ($nice) {
6003         print 'hi';
6004     }
6005     if ($nice) {
6006         print 'hi';
6007     } else {
6008         print 'bye';
6009     }
6010
6011 turns into
6012
6013     $nice and print 'hi';
6014     $nice and do { print 'hi' };
6015     $nice ? do { print 'hi' } : do { print 'bye' };
6016
6017 Long sequences of elsifs will turn into nested ternary operators, which
6018 B::Deparse doesn't know how to indent nicely.
6019
6020 =back
6021
6022 =head1 USING B::Deparse AS A MODULE
6023
6024 =head2 Synopsis
6025
6026     use B::Deparse;
6027     $deparse = B::Deparse->new("-p", "-sC");
6028     $body = $deparse->coderef2text(\&func);
6029     eval "sub func $body"; # the inverse operation
6030
6031 =head2 Description
6032
6033 B::Deparse can also be used on a sub-by-sub basis from other perl
6034 programs.
6035
6036 =head2 new
6037
6038     $deparse = B::Deparse->new(OPTIONS)
6039
6040 Create an object to store the state of a deparsing operation and any
6041 options.  The options are the same as those that can be given on the
6042 command line (see L</OPTIONS>); options that are separated by commas
6043 after B<-MO=Deparse> should be given as separate strings.
6044
6045 =head2 ambient_pragmas
6046
6047     $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
6048
6049 The compilation of a subroutine can be affected by a few compiler
6050 directives, B<pragmas>.  These are:
6051
6052 =over 4
6053
6054 =item *
6055
6056 use strict;
6057
6058 =item *
6059
6060 use warnings;
6061
6062 =item *
6063
6064 Assigning to the special variable $[
6065
6066 =item *
6067
6068 use integer;
6069
6070 =item *
6071
6072 use bytes;
6073
6074 =item *
6075
6076 use utf8;
6077
6078 =item *
6079
6080 use re;
6081
6082 =back
6083
6084 Ordinarily, if you use B::Deparse on a subroutine which has
6085 been compiled in the presence of one or more of these pragmas,
6086 the output will include statements to turn on the appropriate
6087 directives.  So if you then compile the code returned by coderef2text,
6088 it will behave the same way as the subroutine which you deparsed.
6089
6090 However, you may know that you intend to use the results in a
6091 particular context, where some pragmas are already in scope.  In
6092 this case, you use the B<ambient_pragmas> method to describe the
6093 assumptions you wish to make.
6094
6095 Not all of the options currently have any useful effect.  See
6096 L</BUGS> for more details.
6097
6098 The parameters it accepts are:
6099
6100 =over 4
6101
6102 =item strict
6103
6104 Takes a string, possibly containing several values separated
6105 by whitespace.  The special values "all" and "none" mean what you'd
6106 expect.
6107
6108     $deparse->ambient_pragmas(strict => 'subs refs');
6109
6110 =item $[
6111
6112 Takes a number, the value of the array base $[.
6113 Cannot be non-zero on Perl 5.15.3 or later.
6114
6115 =item bytes
6116
6117 =item utf8
6118
6119 =item integer
6120
6121 If the value is true, then the appropriate pragma is assumed to
6122 be in the ambient scope, otherwise not.
6123
6124 =item re
6125
6126 Takes a string, possibly containing a whitespace-separated list of
6127 values.  The values "all" and "none" are special.  It's also permissible
6128 to pass an array reference here.
6129
6130     $deparser->ambient_pragmas(re => 'eval');
6131
6132
6133 =item warnings
6134
6135 Takes a string, possibly containing a whitespace-separated list of
6136 values.  The values "all" and "none" are special, again.  It's also
6137 permissible to pass an array reference here.
6138
6139     $deparser->ambient_pragmas(warnings => [qw[void io]]);
6140
6141 If one of the values is the string "FATAL", then all the warnings
6142 in that list will be considered fatal, just as with the B<warnings>
6143 pragma itself.  Should you need to specify that some warnings are
6144 fatal, and others are merely enabled, you can pass the B<warnings>
6145 parameter twice:
6146
6147     $deparser->ambient_pragmas(
6148         warnings => 'all',
6149         warnings => [FATAL => qw/void io/],
6150     );
6151
6152 See L<warnings> for more information about lexical warnings.
6153
6154 =item hint_bits
6155
6156 =item warning_bits
6157
6158 These two parameters are used to specify the ambient pragmas in
6159 the format used by the special variables $^H and ${^WARNING_BITS}.
6160
6161 They exist principally so that you can write code like:
6162
6163     { my ($hint_bits, $warning_bits);
6164     BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
6165     $deparser->ambient_pragmas (
6166         hint_bits    => $hint_bits,
6167         warning_bits => $warning_bits,
6168         '$['         => 0 + $[
6169     ); }
6170
6171 which specifies that the ambient pragmas are exactly those which
6172 are in scope at the point of calling.
6173
6174 =item %^H
6175
6176 This parameter is used to specify the ambient pragmas which are
6177 stored in the special hash %^H.
6178
6179 =back
6180
6181 =head2 coderef2text
6182
6183     $body = $deparse->coderef2text(\&func)
6184     $body = $deparse->coderef2text(sub ($$) { ... })
6185
6186 Return source code for the body of a subroutine (a block, optionally
6187 preceded by a prototype in parens), given a reference to the
6188 sub.  Because a subroutine can have no names, or more than one name,
6189 this method doesn't return a complete subroutine definition -- if you
6190 want to eval the result, you should prepend "sub subname ", or "sub "
6191 for an anonymous function constructor.  Unless the sub was defined in
6192 the main:: package, the code will include a package declaration.
6193
6194 =head1 BUGS
6195
6196 =over 4
6197
6198 =item *
6199
6200 In Perl 5.20 and earlier, the only pragmas to
6201 be completely supported are: C<use warnings>,
6202 C<use strict>, C<use bytes>, C<use integer>
6203 and C<use feature>.  (C<$[>, which
6204 behaves like a pragma, is also supported.)
6205
6206 Excepting those listed above, we're currently unable to guarantee that
6207 B::Deparse will produce a pragma at the correct point in the program.
6208 (Specifically, pragmas at the beginning of a block often appear right
6209 before the start of the block instead.)
6210 Since the effects of pragmas are often lexically scoped, this can mean
6211 that the pragma holds sway over a different portion of the program
6212 than in the input file.
6213
6214 =item *
6215
6216 In fact, the above is a specific instance of a more general problem:
6217 we can't guarantee to produce BEGIN blocks or C<use> declarations in
6218 exactly the right place.  So if you use a module which affects compilation
6219 (such as by over-riding keywords, overloading constants or whatever)
6220 then the output code might not work as intended.
6221
6222 This is the most serious problem in Perl 5.20 and earlier.  Fixing this
6223 required internal changes in Perl 5.22.
6224
6225 =item *
6226
6227 Some constants don't print correctly either with or without B<-d>.
6228 For instance, neither B::Deparse nor Data::Dumper know how to print
6229 dual-valued scalars correctly, as in:
6230
6231     use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
6232
6233     use constant H => { "#" => 1 }; H->{"#"};
6234
6235 =item *
6236
6237 An input file that uses source filtering probably won't be deparsed into
6238 runnable code, because it will still include the B<use> declaration
6239 for the source filtering module, even though the code that is
6240 produced is already ordinary Perl which shouldn't be filtered again.
6241
6242 =item *
6243
6244 Optimized-away statements are rendered as
6245 '???'.  This includes statements that
6246 have a compile-time side-effect, such as the obscure
6247
6248     my $x if 0;
6249
6250 which is not, consequently, deparsed correctly.
6251
6252     foreach my $i (@_) { 0 }
6253   =>
6254     foreach my $i (@_) { '???' }
6255
6256 =item *
6257
6258 Lexical (my) variables declared in scopes external to a subroutine
6259 appear in code2ref output text as package variables.  This is a tricky
6260 problem, as perl has no native facility for referring to a lexical variable
6261 defined within a different scope, although L<PadWalker> is a good start.
6262
6263 See also L<Data::Dump::Streamer>, which combines B::Deparse and
6264 L<PadWalker> to serialize closures properly.
6265
6266 =item *
6267
6268 There are probably many more bugs on non-ASCII platforms (EBCDIC).
6269
6270 =item *
6271
6272 Prior to Perl 5.22, lexical C<my> subroutines were not deparsed properly.
6273 They were emitted as pure declarations, sometimes in the wrong place.
6274 Lexical C<state> subroutines were not deparsed at all.
6275
6276 =back
6277
6278 =head1 AUTHOR
6279
6280 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version
6281 by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from
6282 Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
6283 Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael
6284 Garcia-Suarez.
6285
6286 =cut