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