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