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