2 # Copyright (c) 1998-2000, 2002, 2003, 2004, 2005, 2006 Stephen McCamant.
4 # This module is free software; you can redistribute and/or modify
5 # it under the same terms as Perl itself.
7 # This is based on the module of the same name by Malcolm Beattie,
8 # but essentially none of his code remains.
12 use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
13 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
14 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPf_PARENS
15 OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
16 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
17 OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST
18 OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE
19 SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
22 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
23 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED PMf_EXTENDED_MORE
25 MDEREF_AV_pop_rv2av_aelem
26 MDEREF_AV_gvsv_vivify_rv2av_aelem
27 MDEREF_AV_padsv_vivify_rv2av_aelem
28 MDEREF_AV_vivify_rv2av_aelem
31 MDEREF_HV_pop_rv2hv_helem
32 MDEREF_HV_gvsv_vivify_rv2hv_helem
33 MDEREF_HV_padsv_vivify_rv2hv_helem
34 MDEREF_HV_vivify_rv2hv_helem
50 use vars qw/$AUTOLOAD/;
55 # List version-specific constants here.
56 # Easiest way to keep this code portable between version looks to
57 # be to fake up a dummy constant that will never actually be true.
58 foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
59 OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE
60 RXf_PMf_CHARSET RXf_PMf_KEEPCOPY
61 CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
62 PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES
63 OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV
64 OPpLVREF_CV OPpLVREF_ELEM SVpad_STATE)) {
67 *{$_} = sub () {0} unless *{$_}{CODE};
71 # Changes between 0.50 and 0.51:
72 # - fixed nulled leave with live enter in sort { }
73 # - fixed reference constants (\"str")
74 # - handle empty programs gracefully
75 # - handle infinite loops (for (;;) {}, while (1) {})
76 # - differentiate between 'for my $x ...' and 'my $x; for $x ...'
77 # - various minor cleanups
78 # - moved globals into an object
79 # - added '-u', like B::C
80 # - package declarations using cop_stash
81 # - subs, formats and code sorted by cop_seq
82 # Changes between 0.51 and 0.52:
83 # - added pp_threadsv (special variables under USE_5005THREADS)
84 # - added documentation
85 # Changes between 0.52 and 0.53:
86 # - many changes adding precedence contexts and associativity
87 # - added '-p' and '-s' output style options
88 # - various other minor fixes
89 # Changes between 0.53 and 0.54:
90 # - added support for new 'for (1..100)' optimization,
92 # Changes between 0.54 and 0.55:
93 # - added support for new qr// construct
94 # - added support for new pp_regcreset OP
95 # Changes between 0.55 and 0.56:
96 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
97 # - fixed $# on non-lexicals broken in last big rewrite
98 # - added temporary fix for change in opcode of OP_STRINGIFY
99 # - fixed problem in 0.54's for() patch in 'for (@ary)'
100 # - fixed precedence in conditional of ?:
101 # - tweaked list paren elimination in 'my($x) = @_'
102 # - made continue-block detection trickier wrt. null ops
103 # - fixed various prototype problems in pp_entersub
104 # - added support for sub prototypes that never get GVs
105 # - added unquoting for special filehandle first arg in truncate
106 # - print doubled rv2gv (a bug) as '*{*GV}' instead of illegal '**GV'
107 # - added semicolons at the ends of blocks
108 # - added -l '#line' declaration option -- fixes cmd/subval.t 27,28
109 # Changes between 0.56 and 0.561:
110 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
111 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
112 # Changes between 0.561 and 0.57:
113 # - stylistic changes to symbolic constant stuff
114 # - handled scope in s///e replacement code
115 # - added unquote option for expanding "" into concats, etc.
116 # - split method and proto parts of pp_entersub into separate functions
117 # - various minor cleanups
118 # Changes after 0.57:
119 # - added parens in \&foo (patch by Albert Dvornik)
120 # Changes between 0.57 and 0.58:
121 # - fixed '0' statements that weren't being printed
122 # - added methods for use from other programs
123 # (based on patches from James Duncan and Hugo van der Sanden)
124 # - added -si and -sT to control indenting (also based on a patch from Hugo)
125 # - added -sv to print something else instead of '???'
126 # - preliminary version of utf8 tr/// handling
127 # Changes after 0.58:
128 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
129 # - added support for Hugo's new OP_SETSTATE (like nextstate)
130 # Changes between 0.58 and 0.59
131 # - added support for Chip's OP_METHOD_NAMED
132 # - added support for Ilya's OPpTARGET_MY optimization
133 # - elided arrows before '()' subscripts when possible
134 # Changes between 0.59 and 0.60
135 # - support for method attributes was added
136 # - some warnings fixed
137 # - separate recognition of constant subs
138 # - rewrote continue block handling, now recognizing for loops
139 # - added more control of expanding control structures
140 # Changes between 0.60 and 0.61 (mostly by Robin Houston)
142 # - support for pragmas and 'use'
143 # - support for the little-used $[ variable
144 # - support for __DATA__ sections
146 # - BEGIN, CHECK, INIT and END blocks
147 # - scoping of subroutine declarations fixed
148 # - compile-time output from the input program can be suppressed, so that the
149 # output is just the deparsed code. (a change to O.pm in fact)
150 # - our() declarations
151 # - *all* the known bugs are now listed in the BUGS section
152 # - comprehensive test mechanism (TEST -deparse)
153 # Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
156 # - support for command-line switches (-l, -0, etc.)
157 # Changes between 0.63 and 0.64
158 # - support for //, CHECK blocks, and assertions
159 # - improved handling of foreach loops and lexicals
160 # - option to use Data::Dumper for constants
162 # - discovered lots more bugs not yet fixed
166 # Changes between 0.72 and 0.73
167 # - support new switch constructs
170 # (See also BUGS section at the end of this file)
172 # - finish tr/// changes
173 # - add option for even more parens (generalize \&foo change)
174 # - left/right context
175 # - copy comments (look at real text with $^P?)
176 # - avoid semis in one-statement blocks
177 # - associativity of &&=, ||=, ?:
178 # - ',' => '=>' (auto-unquote?)
179 # - break long lines ("\r" as discretionary break?)
180 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
181 # - more style options: brace style, hex vs. octal, quotes, ...
182 # - print big ints as hex/octal instead of decimal (heuristic?)
183 # - handle 'my $x if 0'?
184 # - version using op_next instead of op_first/sibling?
185 # - avoid string copies (pass arrays, one big join?)
188 # Current test.deparse failures
189 # comp/hints 6 - location of BEGIN blocks wrt. block openings
190 # run/switchI 1 - missing -I switches entirely
191 # perl -Ifoo -e 'print @INC'
192 # op/caller 2 - warning mask propagates backwards before warnings::register
193 # 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
194 # op/getpid 2 - can't assign to shared my() declaration (threads only)
195 # 'my $x : shared = 5'
196 # op/override 7 - parens on overridden require change v-string interpretation
197 # 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
198 # c.f. 'BEGIN { *f = sub {0} }; f 2'
199 # op/pat 774 - losing Unicode-ness of Latin1-only strings
200 # 'use charnames ":short"; $x="\N{latin:a with acute}"'
201 # op/recurse 12 - missing parens on recursive call makes it look like method
203 # op/subst 90 - inconsistent handling of utf8 under "use utf8"
204 # op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
205 # op/tiehandle compile - "use strict" deparsed in the wrong place
207 # ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
208 # ext/Data/Dumper/t/dumper compile
209 # ext/DB_file/several
211 # ext/Ernno/Errno warnings
212 # ext/IO/lib/IO/t/io_sel 23
213 # ext/PerlIO/t/encoding compile
214 # ext/POSIX/t/posix 6
215 # ext/Socket/Socket 8
216 # ext/Storable/t/croak compile
217 # lib/Attribute/Handlers/t/multi compile
218 # lib/bignum/ several
222 # lib/ExtUtils/t/bytes 4
223 # lib/File/DosGlob compile
224 # lib/Filter/Simple/t/data 1
225 # lib/Math/BigInt/t/constant 1
226 # lib/Net/t/config Deparse-warning
227 # lib/overload compile
228 # lib/Switch/ several
230 # lib/Test/Simple several
232 # lib/Tie/File/t/29_downcopy 5
238 # (local($a), local($b)) and local($a, $b) have the same internal
239 # representation but the short form looks better. We notice we can
240 # use a large-scale local when checking the list, but need to prevent
241 # individual locals too. This hash holds the addresses of OPs that
242 # have already had their local-ness accounted for. The same thing
246 # CV for current sub (or main program) being deparsed
249 # Cached hash of lexical variables for curcv: keys are
250 # names prefixed with "m" or "o" (representing my/our), and
251 # each value is an array with two elements indicating the cop_seq
252 # of scopes in which a var of that name is valid and a third ele-
253 # ment referencing the pad name.
256 # COP for statement being deparsed
259 # name of the current package for deparsed code
262 # array of [cop_seq, CV, is_format?, name] for subs and formats we still
263 # want to deparse. The fourth element is a pad name thingy for lexical
264 # subs or a string for special blocks. For other subs, it is undef. For
265 # lexical subs, CV may be undef, indicating a stub declaration.
268 # as above, but [name, prototype] for subs that never got a GV
270 # subs_done, forms_done:
271 # keys are addresses of GVs for subs and formats we've already
272 # deparsed (or at least put into subs_todo)
275 # keys are names of subs for which we've printed declarations.
276 # That means we can omit parentheses from the arguments. It also means we
277 # need to put CORE:: on core functions of the same name.
280 # True when deparsing the replacement part of a substitution.
283 # True when deparsing the argument to \.
288 # cuddle: ' ' or '\n', depending on -sC
293 # A little explanation of how precedence contexts and associativity
296 # deparse() calls each per-op subroutine with an argument $cx (short
297 # for context, but not the same as the cx* in the perl core), which is
298 # a number describing the op's parents in terms of precedence, whether
299 # they're inside an expression or at statement level, etc. (see
300 # chart below). When ops with children call deparse on them, they pass
301 # along their precedence. Fractional values are used to implement
302 # associativity ('($x + $y) + $z' => '$x + $y + $y') and related
303 # parentheses hacks. The major disadvantage of this scheme is that
304 # it doesn't know about right sides and left sides, so say if you
305 # assign a listop to a variable, it can't tell it's allowed to leave
306 # the parens off the listop.
309 # 26 [TODO] inside interpolation context ("")
310 # 25 left terms and list operators (leftward)
314 # 21 right ! ~ \ and unary + and -
319 # 16 nonassoc named unary operators
320 # 15 nonassoc < > <= >= lt gt le ge
321 # 14 nonassoc == != <=> eq ne cmp
328 # 7 right = += -= *= etc.
330 # 5 nonassoc list operators (rightward)
334 # 1 statement modifiers
335 # 0.5 statements, but still print scopes as do { ... }
339 # Nonprinting characters with special meaning:
340 # \cS - steal parens (see maybe_parens_unop)
341 # \n - newline and indent
342 # \t - increase indent
343 # \b - decrease indent ('outdent')
344 # \f - flush left (no indent)
345 # \cK - kill following semicolon, if any
347 # Semicolon handling:
348 # - Individual statements are not deparsed with trailing semicolons.
349 # (If necessary, \cK is tacked on to the end.)
350 # - Whatever code joins statements together or emits them (lineseq,
351 # scopeop, deparse_root) is responsible for adding semicolons where
353 # - use statements are deparsed with trailing semicolons because they are
354 # immediately concatenated with the following statement.
355 # - indent() removes semicolons wherever it sees \cK.
358 BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
359 nextstate dbstate rv2av rv2hv helem custom ]) {
360 eval "sub OP_\U$_ () { " . opnumber($_) . "}"
363 # _pessimise_walk(): recursively walk the optree of a sub,
364 # possibly undoing optimisations along the way.
366 sub _pessimise_walk {
367 my ($self, $startop) = @_;
369 return unless $$startop;
371 for ($op = $startop; $$op; $prevop = $op, $op = $op->sibling) {
372 my $ppname = $op->name;
374 # pessimisations start here
376 if ($ppname eq "padrange") {
378 # the original optimisation either (1) changed this:
379 # pushmark -> (various pad and list and null ops) -> the_rest
380 # or (2), for the = @_ case, changed this:
381 # pushmark -> gv[_] -> rv2av -> (pad stuff) -> the_rest
383 # padrange ----------------------------------------> the_rest
384 # so we just need to convert the padrange back into a
385 # pushmark, and in case (1), set its op_next to op_sibling,
386 # which is the head of the original chain of optimised-away
387 # pad ops, or for (2), set it to sibling->first, which is
388 # the original gv[_].
390 $B::overlay->{$$op} = {
393 private => ($op->private & OPpLVAL_INTRO),
397 # pessimisations end here
399 if (class($op) eq 'PMOP'
400 && ref($op->pmreplroot)
401 && ${$op->pmreplroot}
402 && $op->pmreplroot->isa( 'B::OP' ))
404 $self-> _pessimise_walk($op->pmreplroot);
407 if ($op->flags & OPf_KIDS) {
408 $self-> _pessimise_walk($op->first);
415 # _pessimise_walk_exe(): recursively walk the op_next chain of a sub,
416 # possibly undoing optimisations along the way.
418 sub _pessimise_walk_exe {
419 my ($self, $startop, $visited) = @_;
421 return unless $$startop;
422 return if $visited->{$$startop};
424 for ($op = $startop; $$op; $prevop = $op, $op = $op->next) {
425 last if $visited->{$$op};
426 $visited->{$$op} = 1;
427 my $ppname = $op->name;
429 /^((and|d?or)(assign)?|(map|grep)while|range|cond_expr|once)$/
430 # entertry is also a logop, but its op_other invariably points
431 # into the same chain as the main execution path, so we skip it
433 $self->_pessimise_walk_exe($op->other, $visited);
435 elsif ($ppname eq "subst") {
436 $self->_pessimise_walk_exe($op->pmreplstart, $visited);
438 elsif ($ppname =~ /^(enter(loop|iter))$/) {
439 # redoop and nextop will already be covered by the main block
441 $self->_pessimise_walk_exe($op->lastop, $visited);
444 # pessimisations start here
448 # Go through an optree and "remove" some optimisations by using an
449 # overlay to selectively modify or un-null some ops. Deparsing in the
450 # absence of those optimisations is then easier.
452 # Note that older optimisations are not removed, as Deparse was already
453 # written to recognise them before the pessimise/overlay system was added.
456 my ($self, $root, $start) = @_;
458 # walk tree in root-to-branch order
459 $self->_pessimise_walk($root);
462 # walk tree in execution order
463 $self->_pessimise_walk_exe($start, \%visited);
469 return class($op) eq "NULL";
474 my($cv, $is_form, $name) = @_;
475 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
477 if ($cv->OUTSIDE_SEQ) {
478 $seq = $cv->OUTSIDE_SEQ;
479 } elsif (!null($cv->START) and is_state($cv->START)) {
480 $seq = $cv->START->cop_seq;
484 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form, $name];
489 my $ent = shift @{$self->{'subs_todo'}};
491 if (ref $ent->[3]) { # lexical sub
494 # At this point, we may not yet have deparsed the hints that allow
495 # lexical subroutines to be recognized. So adjust the current
496 # hints and deparse them.
497 # When lex subs cease being experimental, we should be able to
500 local $^H = $self->{'hints'};
501 local %^H = %{ $self->{'hinthash'} || {} };
502 local ${^WARNING_BITS} = $self->{'warnings'};
503 feature->import("lexical_subs");
504 warnings->unimport("experimental::lexical_subs");
505 # Here we depend on the fact that individual features
506 # will always set the feature bundle to ‘custom’
507 # (== $feature::hint_mask). If we had another specific bundle
508 # enabled previously, normalise it.
509 if (($self->{'hints'} & $feature::hint_mask)
510 != $feature::hint_mask)
512 if ($self->{'hinthash'}) {
513 delete $self->{'hinthash'}{$_}
514 for grep /^feature_/, keys %{$self->{'hinthash'}};
516 else { $self->{'hinthash'} = {} }
518 = _features_from_bundle(@$self{'hints','hinthash'});
520 push @text, $self->declare_hinthash($self->{'hinthash'}, \%^H,
521 $self->{indent_size}, $^H);
522 push @text, $self->declare_warnings($self->{'warnings'},
524 unless ($self->{'warnings'} // 'u')
525 eq (${^WARNING_BITS } // 'u');
526 $self->{'warnings'} = ${^WARNING_BITS};
527 $self->{'hints'} = $^H;
528 $self->{'hinthash'} = {%^H};
531 # Now emit the sub itself.
532 my $padname = $ent->[3];
533 my $flags = $padname->FLAGS;
535 !$cv || $ent->[0] <= $padname->COP_SEQ_RANGE_LOW
536 ? $self->keyword($flags & SVpad_OUR
538 : $flags & SVpad_STATE
542 # XXX We would do $self->keyword("sub"), but ‘my CORE::sub’
543 # doesn’t work and ‘my sub’ ignores a &sub in scope. I.e.,
544 # we have a core bug here.
545 push @text, "sub " . substr $padname->PVX, 1;
548 push @text, " " . $self->deparse_sub($cv);
549 $text[-1] =~ s/ ;$/;/;
555 return join "", @text;
558 my $name = $ent->[3] // $self->gv_name($gv);
560 return $self->keyword("format") . " $name =\n"
561 . $self->deparse_format($ent->[1]). "\n";
564 if ($name eq "BEGIN") {
565 $use_dec = $self->begin_is_use($cv);
566 if (defined ($use_dec) and $self->{'expand'} < 5) {
567 return () if 0 == length($use_dec);
568 $use_dec =~ s/^(use|no)\b/$self->keyword($1)/e;
572 if ($self->{'linenums'}) {
573 my $line = $gv->LINE;
574 my $file = $gv->FILE;
575 $l = "\n\f#line $line \"$file\"\n";
579 if (class($cv->STASH) ne "SPECIAL") {
580 $stash = $cv->STASH->NAME;
581 if ($stash ne $self->{'curstash'}) {
582 $p = $self->keyword("package") . " $stash;\n";
583 $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
584 $self->{'curstash'} = $stash;
588 return "$p$l$use_dec";
590 if ( $name !~ /::/ and $self->lex_in_scope("&$name")
591 || $self->lex_in_scope("&$name", 1) )
593 $name = "$self->{'curstash'}::$name";
594 } elsif (defined $stash) {
595 $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
597 my $ret = "${p}${l}" . $self->keyword("sub") . " $name "
598 . $self->deparse_sub($cv);
599 $self->{'subs_declared'}{$name} = 1;
604 # Return a "use" declaration for this BEGIN block, if appropriate
606 my ($self, $cv) = @_;
607 my $root = $cv->ROOT;
608 local @$self{qw'curcv curcvlex'} = ($cv);
609 local $B::overlay = {};
610 $self->pessimise($root, $cv->START);
612 #B::walkoptree($cv->ROOT, "debug");
613 my $lineseq = $root->first;
614 return if $lineseq->name ne "lineseq";
616 my $req_op = $lineseq->first->sibling;
617 return if $req_op->name ne "require";
620 if ($req_op->first->private & OPpCONST_BARE) {
621 # Actually it should always be a bareword
622 $module = $self->const_sv($req_op->first)->PV;
623 $module =~ s[/][::]g;
627 $module = $self->const($self->const_sv($req_op->first), 6);
631 my $version_op = $req_op->sibling;
632 return if class($version_op) eq "NULL";
633 if ($version_op->name eq "lineseq") {
634 # We have a version parameter; skip nextstate & pushmark
635 my $constop = $version_op->first->next->next;
637 return unless $self->const_sv($constop)->PV eq $module;
638 $constop = $constop->sibling;
639 $version = $self->const_sv($constop);
640 if (class($version) eq "IV") {
641 $version = $version->int_value;
642 } elsif (class($version) eq "NV") {
643 $version = $version->NV;
644 } elsif (class($version) ne "PVMG") {
645 # Includes PVIV and PVNV
646 $version = $version->PV;
648 # version specified as a v-string
649 $version = 'v'.join '.', map ord, split //, $version->PV;
651 $constop = $constop->sibling;
652 return if $constop->name ne "method_named";
653 return if $self->meth_sv($constop)->PV ne "VERSION";
656 $lineseq = $version_op->sibling;
657 return if $lineseq->name ne "lineseq";
658 my $entersub = $lineseq->first->sibling;
659 if ($entersub->name eq "stub") {
660 return "use $module $version ();\n" if defined $version;
661 return "use $module ();\n";
663 return if $entersub->name ne "entersub";
665 # See if there are import arguments
668 my $svop = $entersub->first->sibling; # Skip over pushmark
669 return unless $self->const_sv($svop)->PV eq $module;
671 # Pull out the arguments
672 for ($svop=$svop->sibling; index($svop->name, "method_") != 0;
673 $svop = $svop->sibling) {
674 $args .= ", " if length($args);
675 $args .= $self->deparse($svop, 6);
679 my $method_named = $svop;
680 return if $method_named->name ne "method_named";
681 my $method_name = $self->meth_sv($method_named)->PV;
683 if ($method_name eq "unimport") {
687 # Certain pragmas are dealt with using hint bits,
688 # so we ignore them here
689 if ($module eq 'strict' || $module eq 'integer'
690 || $module eq 'bytes' || $module eq 'warnings'
691 || $module eq 'feature') {
695 if (defined $version && length $args) {
696 return "$use $module $version ($args);\n";
697 } elsif (defined $version) {
698 return "$use $module $version;\n";
699 } elsif (length $args) {
700 return "$use $module ($args);\n";
702 return "$use $module;\n";
707 my ($self, $pack, $seen) = @_;
709 if (!defined $pack) {
714 $pack =~ s/(::)?$/::/;
716 $stash = \%{"main::$pack"};
720 $INC{"overload.pm"} ? overload::StrVal($stash) : $stash
722 my %stash = svref_2object($stash)->ARRAY;
723 while (my ($key, $val) = each %stash) {
724 my $flags = $val->FLAGS;
725 if ($flags & SVf_ROK) {
726 # A reference. Dump this if it is a reference to a CV.
727 # But skip proxy constant subroutines, as some form of perl-
728 # space visible code must have created them, be it a use
729 # statement, or some direct symbol-table manipulation code that
731 if (class(my $cv = $val->RV) eq "CV") {
734 } elsif ($flags & (SVf_POK|SVf_IOK)) {
735 # Just a prototype. As an ugly but fairly effective way
736 # to find out if it belongs here is to see if the AUTOLOAD
737 # (if any) for the stash was defined in one of our files.
738 my $A = $stash{"AUTOLOAD"};
739 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
740 && class($A->CV) eq "CV") {
742 next unless $AF eq $0 || exists $self->{'files'}{$AF};
744 push @{$self->{'protos_todo'}},
745 [$pack . $key, $flags & SVf_POK ? $val->PV: undef];
746 } elsif (class($val) eq "GV") {
747 if (class(my $cv = $val->CV) ne "SPECIAL") {
748 next if $self->{'subs_done'}{$$val}++;
749 next if $$val != ${$cv->GV}; # Ignore imposters
752 if (class(my $cv = $val->FORM) ne "SPECIAL") {
753 next if $self->{'forms_done'}{$$val}++;
754 next if $$val != ${$cv->GV}; # Ignore imposters
757 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
758 $self->stash_subs($pack . $key, $seen);
768 foreach $ar (@{$self->{'protos_todo'}}) {
769 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
770 push @ret, "sub " . $ar->[0] . "$proto;\n";
772 delete $self->{'protos_todo'};
780 while (length($opt = substr($opts, 0, 1))) {
782 $self->{'cuddle'} = " ";
783 $opts = substr($opts, 1);
784 } elsif ($opt eq "i") {
785 $opts =~ s/^i(\d+)//;
786 $self->{'indent_size'} = $1;
787 } elsif ($opt eq "T") {
788 $self->{'use_tabs'} = 1;
789 $opts = substr($opts, 1);
790 } elsif ($opt eq "v") {
791 $opts =~ s/^v([^.]*)(.|$)//;
792 $self->{'ex_const'} = $1;
799 my $self = bless {}, $class;
800 $self->{'cuddle'} = "\n";
801 $self->{'curcop'} = undef;
802 $self->{'curstash'} = "main";
803 $self->{'ex_const'} = "'???'";
804 $self->{'expand'} = 0;
805 $self->{'files'} = {};
806 $self->{'indent_size'} = 4;
807 $self->{'linenums'} = 0;
808 $self->{'parens'} = 0;
809 $self->{'subs_todo'} = [];
810 $self->{'unquote'} = 0;
811 $self->{'use_dumper'} = 0;
812 $self->{'use_tabs'} = 0;
814 $self->{'ambient_arybase'} = 0;
815 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
816 $self->{'ambient_hints'} = 0;
817 $self->{'ambient_hinthash'} = undef;
820 while (my $arg = shift @_) {
822 $self->{'use_dumper'} = 1;
823 require Data::Dumper;
824 } elsif ($arg =~ /^-f(.*)/) {
825 $self->{'files'}{$1} = 1;
826 } elsif ($arg eq "-l") {
827 $self->{'linenums'} = 1;
828 } elsif ($arg eq "-p") {
829 $self->{'parens'} = 1;
830 } elsif ($arg eq "-P") {
831 $self->{'noproto'} = 1;
832 } elsif ($arg eq "-q") {
833 $self->{'unquote'} = 1;
834 } elsif (substr($arg, 0, 2) eq "-s") {
835 $self->style_opts(substr $arg, 2);
836 } elsif ($arg =~ /^-x(\d)$/) {
837 $self->{'expand'} = $1;
844 # Mask out the bits that L<warnings::register> uses
847 $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
854 # Initialise the contextual information, either from
855 # defaults provided with the ambient_pragmas method,
856 # or from perl's own defaults otherwise.
860 $self->{'arybase'} = $self->{'ambient_arybase'};
861 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
862 ? $self->{'ambient_warnings'} & WARN_MASK
864 $self->{'hints'} = $self->{'ambient_hints'};
865 $self->{'hints'} &= 0xFF if $] < 5.009;
866 $self->{'hinthash'} = $self->{'ambient_hinthash'};
868 # also a convenient place to clear out subs_declared
869 delete $self->{'subs_declared'};
875 my $self = B::Deparse->new(@args);
876 # First deparse command-line args
877 if (defined $^I) { # deparse -i
878 print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
880 if ($^W) { # deparse -w
881 print qq(BEGIN { \$^W = $^W; }\n);
883 if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
884 my $fs = perlstring($/) || 'undef';
885 my $bs = perlstring($O::savebackslash) || 'undef';
886 print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
888 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
889 my @UNITCHECKs = B::unitcheck_av->isa("B::AV")
890 ? B::unitcheck_av->ARRAY
892 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
893 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
894 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
895 my @names = qw(BEGIN UNITCHECK CHECK INIT END);
896 my @blocks = \(@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs);
898 my ($name, $blocks) = (shift @names, shift @blocks);
899 for my $block (@$blocks) {
900 $self->todo($block, 0, $name);
904 local($SIG{"__DIE__"}) =
906 if ($self->{'curcop'}) {
907 my $cop = $self->{'curcop'};
908 my($line, $file) = ($cop->line, $cop->file);
909 print STDERR "While deparsing $file near line $line,\n";
912 $self->{'curcv'} = main_cv;
913 $self->{'curcvlex'} = undef;
914 print $self->print_protos;
915 @{$self->{'subs_todo'}} =
916 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
917 my $root = main_root;
918 local $B::overlay = {};
919 unless (null $root) {
920 $self->pad_subs($self->{'curcv'});
921 # Check for a stub-followed-by-ex-cop, resulting from a program
922 # consisting solely of sub declarations. For backward-compati-
923 # bility (and sane output) we don’t want to emit the stub.
927 # ex-nextstate (or ex-dbstate)
929 if ( $root->name eq 'leave'
930 and ($kid = $root->first)->name eq 'enter'
931 and !null($kid = $kid->sibling) and $kid->name eq 'stub'
932 and !null($kid = $kid->sibling) and $kid->name eq 'null'
933 and class($kid) eq 'COP' and null $kid->sibling )
937 $self->pessimise($root, main_start);
938 print $self->indent($self->deparse_root($root)), "\n";
942 while (scalar(@{$self->{'subs_todo'}})) {
943 push @text, $self->next_todo;
945 print $self->indent(join("", @text)), "\n" if @text;
947 # Print __DATA__ section, if necessary
949 my $laststash = defined $self->{'curcop'}
950 ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
951 if (defined *{$laststash."::DATA"}{IO}) {
952 print $self->keyword("package") . " $laststash;\n"
953 unless $laststash eq $self->{'curstash'};
954 print $self->keyword("__DATA__") . "\n";
955 print readline(*{$laststash."::DATA"});
963 croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
966 return $self->indent($self->deparse_sub(svref_2object($sub)));
969 my %strict_bits = do {
971 map +($_ => strict::bits($_)), qw/refs subs vars/
974 sub ambient_pragmas {
976 my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
982 if ($name eq 'strict') {
985 if ($val eq 'none') {
986 $hint_bits &= $strict_bits{$_} for qw/refs subs vars/;
992 @names = qw/refs subs vars/;
998 @names = split' ', $val;
1000 $hint_bits |= $strict_bits{$_} for @names;
1003 elsif ($name eq '$[') {
1004 if (OPpCONST_ARYBASE) {
1007 croak "\$[ can't be non-zero on this perl" unless $val == 0;
1011 elsif ($name eq 'integer'
1013 || $name eq 'utf8') {
1016 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
1019 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
1023 elsif ($name eq 're') {
1025 if ($val eq 'none') {
1026 $hint_bits &= ~re::bits(qw/taint eval/);
1031 if ($val eq 'all') {
1032 @names = qw/taint eval/;
1038 @names = split' ',$val;
1040 $hint_bits |= re::bits(@names);
1043 elsif ($name eq 'warnings') {
1044 if ($val eq 'none') {
1045 $warning_bits = $warnings::NONE;
1054 @names = split/\s+/, $val;
1057 $warning_bits = $warnings::NONE if !defined ($warning_bits);
1058 $warning_bits |= warnings::bits(@names);
1061 elsif ($name eq 'warning_bits') {
1062 $warning_bits = $val;
1065 elsif ($name eq 'hint_bits') {
1069 elsif ($name eq '%^H') {
1074 croak "Unknown pragma type: $name";
1078 croak "The ambient_pragmas method expects an even number of args";
1081 $self->{'ambient_arybase'} = $arybase;
1082 $self->{'ambient_warnings'} = $warning_bits;
1083 $self->{'ambient_hints'} = $hint_bits;
1084 $self->{'ambient_hinthash'} = $hinthash;
1087 # This method is the inner loop, so try to keep it simple
1092 Carp::confess("Null op in deparse") if !defined($op)
1093 || class($op) eq "NULL";
1094 my $meth = "pp_" . $op->name;
1095 return $self->$meth($op, $cx);
1101 # \cK also swallows a preceding line break when followed by a
1103 $txt =~ s/\n\cK;//g;
1104 my @lines = split(/\n/, $txt);
1108 for $line (@lines) {
1109 my $cmd = substr($line, 0, 1);
1110 if ($cmd eq "\t" or $cmd eq "\b") {
1111 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
1112 if ($self->{'use_tabs'}) {
1113 $leader = "\t" x ($level / 8) . " " x ($level % 8);
1115 $leader = " " x $level;
1117 $line = substr($line, 1);
1119 if (index($line, "\f") > 0) {
1122 if (substr($line, 0, 1) eq "\f") {
1123 $line = substr($line, 1); # no indent
1125 $line = $leader . $line;
1127 $line =~ s/\cK;?//g;
1129 return join("\n", @lines);
1133 my ($self, $cv) = @_;
1134 my $padlist = $cv->PADLIST;
1135 my @names = $padlist->ARRAYelt(0)->ARRAY;
1136 my @values = $padlist->ARRAYelt(1)->ARRAY;
1138 for my $ix (0.. $#names) { for $_ ($names[$ix]) {
1139 next if class($_) eq "SPECIAL";
1141 if (defined $name && $name =~ /^&./) {
1142 my $low = $_->COP_SEQ_RANGE_LOW;
1143 my $flags = $_->FLAGS;
1144 if ($flags & SVpad_OUR) {
1145 push @todo, [$low, undef, 0, $_];
1146 # [seq, no cv, not format, padname]
1149 my $protocv = $flags & SVpad_STATE
1152 my $outseq = $protocv->OUTSIDE_SEQ;
1153 if ($outseq <= $low) {
1154 # defined before its name is visible, so it’s gotta be
1155 # declared and defined at once: my sub foo { ... }
1156 push @todo, [$low, $protocv, 0, $_];
1159 # declared and defined separately: my sub f; sub f { ... }
1160 push @todo, [$low, undef, 0, $_],
1161 [$outseq, $protocv, 0, $_];
1165 @{$self->{'subs_todo'}} =
1166 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo
1173 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
1174 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
1175 local $self->{'curcop'} = $self->{'curcop'};
1176 if ($cv->FLAGS & SVf_POK) {
1177 $proto = "(". $cv->PV . ") ";
1179 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
1181 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
1182 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
1183 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
1186 local($self->{'curcv'}) = $cv;
1187 local($self->{'curcvlex'});
1188 local(@$self{qw'curstash warnings hints hinthash'})
1189 = @$self{qw'curstash warnings hints hinthash'};
1191 my $root = $cv->ROOT;
1192 local $B::overlay = {};
1193 if (not null $root) {
1194 $self->pad_subs($cv);
1195 $self->pessimise($root, $cv->START);
1196 my $lineseq = $root->first;
1197 if ($lineseq->name eq "lineseq") {
1199 for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
1202 $body = $self->lineseq(undef, 0, @ops).";";
1203 my $scope_en = $self->find_scope_en($lineseq);
1204 if (defined $scope_en) {
1205 my $subs = join"", $self->seq_subs($scope_en);
1206 $body .= ";\n$subs" if length($subs);
1210 $body = $self->deparse($root->first, 0);
1214 my $sv = $cv->const_sv;
1216 # uh-oh. inlinable sub... format it differently
1217 return $proto . "{ " . $self->const($sv, 0) . " }\n";
1218 } else { # XSUB? (or just a declaration)
1222 return $proto ."{\n\t$body\n\b}" ."\n";
1225 sub deparse_format {
1229 local($self->{'curcv'}) = $form;
1230 local($self->{'curcvlex'});
1231 local($self->{'in_format'}) = 1;
1232 local(@$self{qw'curstash warnings hints hinthash'})
1233 = @$self{qw'curstash warnings hints hinthash'};
1234 my $op = $form->ROOT;
1235 local $B::overlay = {};
1236 $self->pessimise($op, $form->START);
1238 return "\f." if $op->first->name eq 'stub'
1239 || $op->first->name eq 'nextstate';
1240 $op = $op->first->first; # skip leavewrite, lineseq
1241 while (not null $op) {
1242 $op = $op->sibling; # skip nextstate
1244 $kid = $op->first->sibling; # skip pushmark
1245 push @text, "\f".$self->const_sv($kid)->PV;
1246 $kid = $kid->sibling;
1247 for (; not null $kid; $kid = $kid->sibling) {
1248 push @exprs, $self->deparse($kid, -1);
1249 $exprs[-1] =~ s/;\z//;
1251 push @text, "\f".join(", ", @exprs)."\n" if @exprs;
1254 return join("", @text) . "\f.";
1259 return $op->name eq "leave" || $op->name eq "scope"
1260 || $op->name eq "lineseq"
1261 || ($op->name eq "null" && class($op) eq "UNOP"
1262 && (is_scope($op->first) || $op->first->name eq "enter"));
1266 my $name = $_[0]->name;
1267 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
1270 sub is_miniwhile { # check for one-line loop ('foo() while $y--')
1272 return (!null($op) and null($op->sibling)
1273 and $op->name eq "null" and class($op) eq "UNOP"
1274 and (($op->first->name =~ /^(and|or)$/
1275 and $op->first->first->sibling->name eq "lineseq")
1276 or ($op->first->name eq "lineseq"
1277 and not null $op->first->first->sibling
1278 and $op->first->first->sibling->name eq "unstack")
1282 # Check if the op and its sibling are the initialization and the rest of a
1283 # for (..;..;..) { ... } loop
1286 # This OP might be almost anything, though it won't be a
1287 # nextstate. (It's the initialization, so in the canonical case it
1288 # will be an sassign.) The sibling is (old style) a lineseq whose
1289 # first child is a nextstate and whose second is a leaveloop, or
1290 # (new style) an unstack whose sibling is a leaveloop.
1291 my $lseq = $op->sibling;
1292 return 0 unless !is_state($op) and !null($lseq);
1293 if ($lseq->name eq "lineseq") {
1294 if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
1295 && (my $sib = $lseq->first->sibling)) {
1296 return (!null($sib) && $sib->name eq "leaveloop");
1298 } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) {
1299 my $sib = $lseq->sibling;
1300 return $sib && !null($sib) && $sib->name eq "leaveloop";
1307 return ($op->name eq "rv2sv" or
1308 $op->name eq "padsv" or
1309 $op->name eq "gv" or # only in array/hash constructs
1310 $op->flags & OPf_KIDS && !null($op->first)
1311 && $op->first->name eq "gvsv");
1316 my($text, $cx, $prec) = @_;
1317 if ($prec < $cx # unary ops nest just fine
1318 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
1319 or $self->{'parens'})
1322 # In a unop, let parent reuse our parens; see maybe_parens_unop
1323 $text = "\cS" . $text if $cx == 16;
1330 # same as above, but get around the 'if it looks like a function' rule
1331 sub maybe_parens_unop {
1333 my($name, $kid, $cx) = @_;
1334 if ($cx > 16 or $self->{'parens'}) {
1335 $kid = $self->deparse($kid, 1);
1336 if ($name eq "umask" && $kid =~ /^\d+$/) {
1337 $kid = sprintf("%#o", $kid);
1339 return $self->keyword($name) . "($kid)";
1341 $kid = $self->deparse($kid, 16);
1342 if ($name eq "umask" && $kid =~ /^\d+$/) {
1343 $kid = sprintf("%#o", $kid);
1345 $name = $self->keyword($name);
1346 if (substr($kid, 0, 1) eq "\cS") {
1348 return $name . substr($kid, 1);
1349 } elsif (substr($kid, 0, 1) eq "(") {
1350 # avoid looks-like-a-function trap with extra parens
1351 # ('+' can lead to ambiguities)
1352 return "$name(" . $kid . ")";
1354 return "$name $kid";
1359 sub maybe_parens_func {
1361 my($func, $text, $cx, $prec) = @_;
1362 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
1363 return "$func($text)";
1365 return "$func $text";
1370 my ($self, $name) = @_;
1371 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1372 my $seq = $self->{'curcop'} ? $self->{'curcop'}->cop_seq : 0;
1373 for my $a (@{$self->{'curcvlex'}{"o$name"}}) {
1374 my ($st, undef, $padname) = @$a;
1375 if ($st >= $seq && $padname->FLAGS & SVpad_TYPED) {
1376 return $padname->SvSTASH->NAME;
1384 my($op, $cx, $text) = @_;
1385 my $name = $op->name;
1386 my $our_intro = ($name =~ /^(?:(?:gv|rv2)[ash]v|split|refassign
1390 my $lval_intro = $name eq 'split' ? 0 : OPpLVAL_INTRO;
1391 # The @a in \(@a) isn't in ref context, but only when the
1393 my $need_parens = $self->{'in_refgen'} && $name =~ /[ah]v\z/
1394 && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
1395 if ((my $priv = $op->private) & ($lval_intro|$our_intro)) {
1397 push @our_local, "local" if $priv & $lval_intro;
1398 push @our_local, "our" if $priv & $our_intro;
1399 my $our_local = join " ", map $self->keyword($_), @our_local;
1400 if( $our_local[-1] eq 'our' ) {
1401 if ( $text !~ /^\W(\w+::)*\w+\z/
1402 and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
1404 die "Unexpected our($text)\n";
1406 $text =~ s/(\w+::)+//;
1408 if (my $type = $self->find_our_type($text)) {
1409 $our_local .= ' ' . $type;
1412 return $need_parens ? "($text)" : $text
1413 if $self->{'avoid_local'}{$$op};
1415 return "$our_local($text)";
1416 } elsif (want_scalar($op)) {
1417 return "$our_local $text";
1419 return $self->maybe_parens_func("$our_local", $text, $cx, 16);
1422 return $need_parens ? "($text)" : $text;
1428 my($op, $cx, $func, @args) = @_;
1429 if ($op->private & OPpTARGET_MY) {
1430 my $var = $self->padname($op->targ);
1431 my $val = $func->($self, $op, 7, @args);
1432 return $self->maybe_parens("$var = $val", $cx, 7);
1434 return $func->($self, $op, $cx, @args);
1441 return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
1446 my($op, $cx, $text, $padname, $forbid_parens) = @_;
1447 # The @a in \(@a) isn't in ref context, but only when the
1449 my $need_parens = !$forbid_parens && $self->{'in_refgen'}
1450 && $op->name =~ /[ah]v\z/
1451 && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
1452 # The @a in \my @a must not have parens.
1453 if (!$need_parens && $self->{'in_refgen'}) {
1456 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
1457 # Check $padname->FLAGS for statehood, rather than $op->private,
1458 # because enteriter ops do not carry the flag.
1460 $self->keyword($padname->FLAGS & SVpad_STATE ? "state" : "my");
1461 if ($padname->FLAGS & SVpad_TYPED) {
1462 $my .= ' ' . $padname->SvSTASH->NAME;
1465 return "$my($text)";
1466 } elsif ($forbid_parens || want_scalar($op)) {
1469 return $self->maybe_parens_func($my, $text, $cx, 16);
1472 return $need_parens ? "($text)" : $text;
1476 # The following OPs don't have functions:
1478 # pp_padany -- does not exist after parsing
1481 if ($AUTOLOAD =~ s/^.*::pp_//) {
1482 warn "unexpected OP_".
1483 ($_[1]->type == OP_CUSTOM ? "CUSTOM ($AUTOLOAD)" : uc $AUTOLOAD);
1486 die "Undefined subroutine $AUTOLOAD called";
1490 sub DESTROY {} # Do not AUTOLOAD
1492 # $root should be the op which represents the root of whatever
1493 # we're sequencing here. If it's undefined, then we don't append
1494 # any subroutine declarations to the deparsed ops, otherwise we
1495 # append appropriate declarations.
1497 my($self, $root, $cx, @ops) = @_;
1500 my $out_cop = $self->{'curcop'};
1501 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1503 if (defined $root) {
1504 $limit_seq = $out_seq;
1506 $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
1507 $limit_seq = $nseq if !defined($limit_seq)
1508 or defined($nseq) && $nseq < $limit_seq;
1510 $limit_seq = $self->{'limit_seq'}
1511 if defined($self->{'limit_seq'})
1512 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1513 local $self->{'limit_seq'} = $limit_seq;
1515 $self->walk_lineseq($root, \@ops,
1516 sub { push @exprs, $_[0]} );
1518 my $sep = $cx ? '; ' : ";\n";
1519 my $body = join($sep, grep {length} @exprs);
1521 if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
1522 $subs = join "\n", $self->seq_subs($limit_seq);
1524 return join($sep, grep {length} $body, $subs);
1528 my($real_block, $self, $op, $cx) = @_;
1532 local(@$self{qw'curstash warnings hints hinthash'})
1533 = @$self{qw'curstash warnings hints hinthash'} if $real_block;
1535 $kid = $op->first->sibling; # skip enter
1536 if (is_miniwhile($kid)) {
1537 my $top = $kid->first;
1538 my $name = $top->name;
1539 if ($name eq "and") {
1540 $name = $self->keyword("while");
1541 } elsif ($name eq "or") {
1542 $name = $self->keyword("until");
1543 } else { # no conditional -> while 1 or until 0
1544 return $self->deparse($top->first, 1) . " "
1545 . $self->keyword("while") . " 1";
1547 my $cond = $top->first;
1548 my $body = $cond->sibling->first; # skip lineseq
1549 $cond = $self->deparse($cond, 1);
1550 $body = $self->deparse($body, 1);
1551 return "$body $name $cond";
1556 for (; !null($kid); $kid = $kid->sibling) {
1559 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
1560 my $body = $self->lineseq($op, 0, @kids);
1561 return is_lexical_subs(@kids)
1563 : ($self->lex_in_scope("&do") ? "CORE::do" : "do")
1564 . " {\n\t$body\n\b}";
1566 my $lineseq = $self->lineseq($op, $cx, @kids);
1567 return (length ($lineseq) ? "$lineseq;" : "");
1571 sub pp_scope { scopeop(0, @_); }
1572 sub pp_lineseq { scopeop(0, @_); }
1573 sub pp_leave { scopeop(1, @_); }
1575 # This is a special case of scopeop and lineseq, for the case of the
1576 # main_root. The difference is that we print the output statements as
1577 # soon as we get them, for the sake of impatient users.
1581 local(@$self{qw'curstash warnings hints hinthash'})
1582 = @$self{qw'curstash warnings hints hinthash'};
1584 return if null $op->first; # Can happen, e.g., for Bytecode without -k
1585 for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
1588 $self->walk_lineseq($op, \@kids,
1589 sub { return unless length $_[0];
1590 print $self->indent($_[0].';');
1592 unless $_[1] == $#kids;
1597 my ($self, $op, $kids, $callback) = @_;
1599 for (my $i = 0; $i < @kids; $i++) {
1601 if (is_state $kids[$i]) {
1602 $expr = $self->deparse($kids[$i++], 0);
1604 $callback->($expr, $i);
1608 if (is_for_loop($kids[$i])) {
1609 $callback->($expr . $self->for_loop($kids[$i], 0),
1610 $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
1613 my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2);
1614 $expr2 =~ s/^sub :(?!:)/+sub :/; # statement label otherwise
1616 $callback->($expr, $i);
1620 # The BEGIN {} is used here because otherwise this code isn't executed
1621 # when you run B::Deparse on itself.
1623 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1624 "ENV", "ARGV", "ARGVOUT", "_"); }
1630 #Carp::confess() unless ref($gv) eq "B::GV";
1631 my $cv = $gv->FLAGS & SVf_ROK ? $gv->RV : 0;
1632 my $stash = ($cv || $gv)->STASH->NAME;
1634 ? $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME
1636 ? B::safename($cv->NAME_HEK || $cv->GV->NAME)
1638 if ($stash eq 'main' && $name =~ /^::/) {
1641 elsif (($stash eq 'main'
1642 && ($globalnames{$name} || $name =~ /^[^A-Za-z_:]/))
1643 or ($stash eq $self->{'curstash'} && !$globalnames{$name}
1644 && ($stash eq 'main' || $name !~ /::/))
1649 $stash = $stash . "::";
1651 if (!$raw and $name =~ /^(\^..|{)/) {
1652 $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
1654 return $stash . $name;
1657 # Return the name to use for a stash variable.
1658 # If a lexical with the same name is in scope, or
1659 # if strictures are enabled, it may need to be
1661 sub stash_variable {
1662 my ($self, $prefix, $name, $cx) = @_;
1664 return "$prefix$name" if $name =~ /::/;
1666 unless ($prefix eq '$' || $prefix eq '@' || $prefix eq '&' || #'
1667 $prefix eq '%' || $prefix eq '$#') {
1668 return "$prefix$name";
1671 if ($name =~ /^[^[:alpha:]+-]$/) {
1672 if (defined $cx && $cx == 26) {
1673 if ($prefix eq '@') {
1674 return "$prefix\{$name}";
1676 elsif ($name eq '#') { return '${#}' } # "${#}a" vs "$#a"
1678 if ($prefix eq '$#') {
1679 return "\$#{$name}";
1683 return $prefix . $self->maybe_qualify($prefix, $name);
1686 # Return just the name, without the prefix. It may be returned as a quoted
1687 # string. The second return value is a boolean indicating that.
1688 sub stash_variable_name {
1689 my($self, $prefix, $gv) = @_;
1690 my $name = $self->gv_name($gv, 1);
1691 $name = $self->maybe_qualify($prefix,$name);
1692 if ($name =~ /^(?:\S|(?!\d)[\ca-\cz]?(?:\w|::)*|\d+)\z/) {
1693 $name =~ s/^([\ca-\cz])/'^'.($1|'@')/e;
1694 $name =~ /^(\^..|{)/ and $name = "{$name}";
1695 return $name, 0; # not quoted
1698 single_delim("q", "'", $name, $self), 1;
1703 my ($self,$prefix,$name) = @_;
1704 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1705 return $name if !$prefix || $name =~ /::/;
1706 return $self->{'curstash'}.'::'. $name
1708 $name =~ /^(?!\d)\w/ # alphabetic
1709 && $v !~ /^\$[ab]\z/ # not $a or $b
1710 && !$globalnames{$name} # not a global name
1711 && $self->{hints} & $strict_bits{vars} # strict vars
1712 && !$self->lex_in_scope($v,1) # no "our"
1713 or $self->lex_in_scope($v); # conflicts with "my" variable
1718 my ($self, $name, $our) = @_;
1719 substr $name, 0, 0, = $our ? 'o' : 'm'; # our/my
1720 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1722 return 0 if !defined($self->{'curcop'});
1723 my $seq = $self->{'curcop'}->cop_seq;
1724 return 0 if !exists $self->{'curcvlex'}{$name};
1725 for my $a (@{$self->{'curcvlex'}{$name}}) {
1726 my ($st, $en) = @$a;
1727 return 1 if $seq > $st && $seq <= $en;
1732 sub populate_curcvlex {
1734 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1735 my $padlist = $cv->PADLIST;
1736 # an undef CV still in lexical chain
1737 next if class($padlist) eq "SPECIAL";
1738 my @padlist = $padlist->ARRAY;
1739 my @ns = $padlist[0]->ARRAY;
1741 for (my $i=0; $i<@ns; ++$i) {
1742 next if class($ns[$i]) eq "SPECIAL";
1743 if (class($ns[$i]) eq "PV") {
1744 # Probably that pesky lexical @_
1747 my $name = $ns[$i]->PVX;
1748 next unless defined $name;
1749 my ($seq_st, $seq_en) =
1750 ($ns[$i]->FLAGS & SVf_FAKE)
1752 : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH);
1754 push @{$self->{'curcvlex'}{
1755 ($ns[$i]->FLAGS & SVpad_OUR ? 'o' : 'm') . $name
1756 }}, [$seq_st, $seq_en, $ns[$i]];
1761 sub find_scope_st { ((find_scope(@_))[0]); }
1762 sub find_scope_en { ((find_scope(@_))[1]); }
1764 # Recurses down the tree, looking for pad variable introductions and COPs
1766 my ($self, $op, $scope_st, $scope_en) = @_;
1767 carp("Undefined op in find_scope") if !defined $op;
1768 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1771 while(my $op = shift @queue ) {
1772 for (my $o=$op->first; $$o; $o=$o->sibling) {
1773 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1774 my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW);
1775 my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH;
1776 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1777 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1778 return ($scope_st, $scope_en);
1780 elsif (is_state($o)) {
1781 my $c = $o->cop_seq;
1782 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1783 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1784 return ($scope_st, $scope_en);
1786 elsif ($o->flags & OPf_KIDS) {
1787 unshift (@queue, $o);
1792 return ($scope_st, $scope_en);
1795 # Returns a list of subs which should be inserted before the COP
1797 my ($self, $op, $out_seq) = @_;
1798 my $seq = $op->cop_seq;
1799 if ($] < 5.021006) {
1800 # If we have nephews, then our sequence number indicates
1801 # the cop_seq of the end of some sort of scope.
1802 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1803 and my $nseq = $self->find_scope_st($op->sibling) ) {
1807 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1808 return $self->seq_subs($seq);
1812 my ($self, $seq) = @_;
1814 #push @text, "# ($seq)\n";
1816 return "" if !defined $seq;
1818 while (scalar(@{$self->{'subs_todo'}})
1819 and $seq > $self->{'subs_todo'}[0][0]) {
1820 my $cv = $self->{'subs_todo'}[0][1];
1821 # Skip the OUTSIDE check for lexical subs. We may be deparsing a
1822 # cloned anon sub with lexical subs declared in it, in which case
1823 # the OUTSIDE pointer points to the anon protosub.
1824 my $lexical = ref $self->{'subs_todo'}[0][3];
1825 my $outside = !$lexical && $cv && $cv->OUTSIDE;
1826 if (!$lexical and $cv
1827 and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}})
1829 push @pending, shift @{$self->{'subs_todo'}};
1832 push @text, $self->next_todo;
1834 unshift @{$self->{'subs_todo'}}, @pending;
1838 sub _features_from_bundle {
1839 my ($hints, $hh) = @_;
1840 foreach (@{$feature::feature_bundle{@feature::hint_bundles[$hints >> $feature::hint_shift]}}) {
1841 $hh->{$feature::feature{$_}} = 1;
1846 # Notice how subs and formats are inserted between statements here;
1847 # also $[ assignments and pragmas.
1851 $self->{'curcop'} = $op;
1853 push @text, $self->cop_subs($op);
1855 # Special marker to swallow up the semicolon
1858 my $stash = $op->stashpv;
1859 if ($stash ne $self->{'curstash'}) {
1860 push @text, $self->keyword("package") . " $stash;\n";
1861 $self->{'curstash'} = $stash;
1864 if (OPpCONST_ARYBASE && $self->{'arybase'} != $op->arybase) {
1865 push @text, '$[ = '. $op->arybase .";\n";
1866 $self->{'arybase'} = $op->arybase;
1869 my $warnings = $op->warnings;
1871 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1872 $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
1874 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1875 $warning_bits = $warnings::NONE;
1877 elsif ($warnings->isa("B::SPECIAL")) {
1878 $warning_bits = undef;
1881 $warning_bits = $warnings->PV & WARN_MASK;
1884 if (defined ($warning_bits) and
1885 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1887 $self->declare_warnings($self->{'warnings'}, $warning_bits);
1888 $self->{'warnings'} = $warning_bits;
1891 my $hints = $] < 5.008009 ? $op->private : $op->hints;
1892 my $old_hints = $self->{'hints'};
1893 if ($self->{'hints'} != $hints) {
1894 push @text, $self->declare_hints($self->{'hints'}, $hints);
1895 $self->{'hints'} = $hints;
1900 $newhh = $op->hints_hash->HASH;
1903 if ($] >= 5.015006) {
1904 # feature bundle hints
1905 my $from = $old_hints & $feature::hint_mask;
1906 my $to = $ hints & $feature::hint_mask;
1908 if ($to == $feature::hint_mask) {
1909 if ($self->{'hinthash'}) {
1910 delete $self->{'hinthash'}{$_}
1911 for grep /^feature_/, keys %{$self->{'hinthash'}};
1913 else { $self->{'hinthash'} = {} }
1915 = _features_from_bundle($from, $self->{'hinthash'});
1919 $feature::hint_bundles[$to >> $feature::hint_shift];
1920 $bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12
1922 $self->keyword("no") . " feature ':all';\n",
1923 $self->keyword("use") . " feature ':$bundle';\n";
1929 push @text, $self->declare_hinthash(
1930 $self->{'hinthash'}, $newhh,
1931 $self->{indent_size}, $self->{hints},
1933 $self->{'hinthash'} = $newhh;
1936 # This should go after of any branches that add statements, to
1937 # increase the chances that it refers to the same line it did in
1938 # the original program.
1939 if ($self->{'linenums'} && $cx != .5) { # $cx == .5 means in a format
1940 push @text, "\f#line " . $op->line .
1941 ' "' . $op->file, qq'"\n';
1944 push @text, $op->label . ": " if $op->label;
1946 return join("", @text);
1949 sub declare_warnings {
1950 my ($self, $from, $to) = @_;
1951 if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
1952 return $self->keyword("use") . " warnings;\n";
1954 elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
1955 return $self->keyword("no") . " warnings;\n";
1957 return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n\cK";
1961 my ($self, $from, $to) = @_;
1962 my $use = $to & ~$from;
1963 my $no = $from & ~$to;
1965 for my $pragma (hint_pragmas($use)) {
1966 $decls .= $self->keyword("use") . " $pragma;\n";
1968 for my $pragma (hint_pragmas($no)) {
1969 $decls .= $self->keyword("no") . " $pragma;\n";
1974 # Internal implementation hints that the core sets automatically, so don't need
1975 # (or want) to be passed back to the user
1976 my %ignored_hints = (
1987 sub declare_hinthash {
1988 my ($self, $from, $to, $indent, $hints) = @_;
1989 my $doing_features =
1990 ($hints & $feature::hint_mask) == $feature::hint_mask;
1993 my @unfeatures; # bugs?
1994 for my $key (sort keys %$to) {
1995 next if $ignored_hints{$key};
1996 my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6;
1997 next if $is_feature and not $doing_features;
1998 if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) {
1999 push(@features, $key), next if $is_feature;
2001 qq(\$^H{) . single_delim("q", "'", $key, $self) . qq(} = )
2004 ? single_delim("q", "'", $to->{$key}, $self)
2010 for my $key (sort keys %$from) {
2011 next if $ignored_hints{$key};
2012 my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6;
2013 next if $is_feature and not $doing_features;
2014 if (!exists $to->{$key}) {
2015 push(@unfeatures, $key), next if $is_feature;
2016 push @decls, qq(delete \$^H{'$key'};);
2020 if (@features || @unfeatures) {
2021 if (!%rev_feature) { %rev_feature = reverse %feature::feature }
2024 push @ret, $self->keyword("use") . " feature "
2025 . join(", ", map "'$rev_feature{$_}'", @features) . ";\n";
2028 push @ret, $self->keyword("no") . " feature "
2029 . join(", ", map "'$rev_feature{$_}'", @unfeatures)
2034 join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n\cK";
2040 my (@pragmas, @strict);
2041 push @pragmas, "integer" if $bits & 0x1;
2042 for (sort keys %strict_bits) {
2043 push @strict, "'$_'" if $bits & $strict_bits{$_};
2045 if (@strict == keys %strict_bits) {
2046 push @pragmas, "strict";
2049 push @pragmas, "strict " . join ', ', @strict;
2051 push @pragmas, "bytes" if $bits & 0x8;
2055 sub pp_dbstate { pp_nextstate(@_) }
2056 sub pp_setstate { pp_nextstate(@_) }
2058 sub pp_unstack { return "" } # see also leaveloop
2060 my %feature_keywords = (
2061 # keyword => 'feature',
2066 default => 'switch',
2068 evalbytes=>'evalbytes',
2069 __SUB__ => '__SUB__',
2073 # keywords that are strong and also have a prototype
2075 my %strong_proto_keywords = map { $_ => 1 } qw(
2083 sub feature_enabled {
2084 my($self,$name) = @_;
2086 my $hints = $self->{hints} & $feature::hint_mask;
2087 if ($hints && $hints != $feature::hint_mask) {
2088 $hh = _features_from_bundle($hints);
2090 elsif ($hints) { $hh = $self->{'hinthash'} }
2091 return $hh && $hh->{"feature_$feature_keywords{$name}"}
2097 return $name if $name =~ /^CORE::/; # just in case
2098 if (exists $feature_keywords{$name}) {
2099 return "CORE::$name" if not $self->feature_enabled($name);
2101 # This sub may be called for a program that has no nextstate ops. In
2102 # that case we may have a lexical sub named no/use/sub in scope but
2103 # but $self->lex_in_scope will return false because it depends on the
2104 # current nextstate op. So we need this alternate method if there is
2106 if (!$self->{'curcop'}) {
2107 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
2108 return "CORE::$name" if exists $self->{'curcvlex'}{"m&$name"}
2109 || exists $self->{'curcvlex'}{"o&$name"};
2110 } elsif ($self->lex_in_scope("&$name")
2111 || $self->lex_in_scope("&$name", 1)) {
2112 return "CORE::$name";
2114 if ($strong_proto_keywords{$name}
2115 || ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
2116 && !defined eval{prototype "CORE::$name"})
2119 exists $self->{subs_declared}{$name}
2121 exists &{"$self->{curstash}::$name"}
2123 return "CORE::$name"
2130 my($op, $cx, $name) = @_;
2131 return $self->keyword($name);
2134 sub pp_stub { "()" }
2135 sub pp_wantarray { baseop(@_, "wantarray") }
2136 sub pp_fork { baseop(@_, "fork") }
2137 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
2138 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
2139 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
2140 sub pp_tms { baseop(@_, "times") }
2141 sub pp_ghostent { baseop(@_, "gethostent") }
2142 sub pp_gnetent { baseop(@_, "getnetent") }
2143 sub pp_gprotoent { baseop(@_, "getprotoent") }
2144 sub pp_gservent { baseop(@_, "getservent") }
2145 sub pp_ehostent { baseop(@_, "endhostent") }
2146 sub pp_enetent { baseop(@_, "endnetent") }
2147 sub pp_eprotoent { baseop(@_, "endprotoent") }
2148 sub pp_eservent { baseop(@_, "endservent") }
2149 sub pp_gpwent { baseop(@_, "getpwent") }
2150 sub pp_spwent { baseop(@_, "setpwent") }
2151 sub pp_epwent { baseop(@_, "endpwent") }
2152 sub pp_ggrent { baseop(@_, "getgrent") }
2153 sub pp_sgrent { baseop(@_, "setgrent") }
2154 sub pp_egrent { baseop(@_, "endgrent") }
2155 sub pp_getlogin { baseop(@_, "getlogin") }
2157 sub POSTFIX () { 1 }
2159 # I couldn't think of a good short name, but this is the category of
2160 # symbolic unary operators with interesting precedence
2164 my($op, $cx, $name, $prec, $flags) = (@_, 0);
2165 my $kid = $op->first;
2166 $kid = $self->deparse($kid, $prec);
2167 return $self->maybe_parens(($flags & POSTFIX)
2169 # avoid confusion with filetests
2171 && $kid =~ /^[a-zA-Z](?!\w)/
2177 sub pp_preinc { pfixop(@_, "++", 23) }
2178 sub pp_predec { pfixop(@_, "--", 23) }
2179 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
2180 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
2181 sub pp_i_preinc { pfixop(@_, "++", 23) }
2182 sub pp_i_predec { pfixop(@_, "--", 23) }
2183 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
2184 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
2185 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
2187 sub pp_negate { maybe_targmy(@_, \&real_negate) }
2191 if ($op->first->name =~ /^(i_)?negate$/) {
2193 $self->pfixop($op, $cx, "-", 21.5);
2195 $self->pfixop($op, $cx, "-", 21);
2198 sub pp_i_negate { pp_negate(@_) }
2204 $self->listop($op, $cx, "not", $op->first);
2206 $self->pfixop($op, $cx, "!", 21);
2212 my($op, $cx, $name, $nollafr) = @_;
2214 if ($op->flags & OPf_KIDS) {
2217 # this deals with 'boolkeys' right now
2218 return $self->deparse($kid,$cx);
2220 my $builtinname = $name;
2221 $builtinname =~ /^CORE::/ or $builtinname = "CORE::$name";
2222 if (defined prototype($builtinname)
2223 && prototype($builtinname) =~ /^;?\*/
2224 && $kid->name eq "rv2gv") {
2229 if (($kid = $self->deparse($kid, 16)) !~ s/^\cS//) {
2230 # require foo() is a syntax error.
2231 $kid =~ /^(?!\d)\w/ and $kid = "($kid)";
2233 return $self->maybe_parens(
2234 $self->keyword($name) . " $kid", $cx, 16
2237 return $self->maybe_parens_unop($name, $kid, $cx);
2239 return $self->maybe_parens(
2240 $self->keyword($name) . ($op->flags & OPf_SPECIAL ? "()" : ""),
2246 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
2247 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
2248 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
2249 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
2250 sub pp_defined { unop(@_, "defined") }
2251 sub pp_undef { unop(@_, "undef") }
2252 sub pp_study { unop(@_, "study") }
2253 sub pp_ref { unop(@_, "ref") }
2254 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
2256 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
2257 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
2258 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
2259 sub pp_srand { unop(@_, "srand") }
2260 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
2261 sub pp_log { maybe_targmy(@_, \&unop, "log") }
2262 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
2263 sub pp_int { maybe_targmy(@_, \&unop, "int") }
2264 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
2265 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
2266 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
2268 sub pp_length { maybe_targmy(@_, \&unop, "length") }
2269 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
2270 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
2272 sub pp_each { unop(@_, "each") }
2273 sub pp_values { unop(@_, "values") }
2274 sub pp_keys { unop(@_, "keys") }
2275 { no strict 'refs'; *{"pp_r$_"} = *{"pp_$_"} for qw< keys each values >; }
2277 # no name because its an optimisation op that has no keyword
2280 sub pp_aeach { unop(@_, "each") }
2281 sub pp_avalues { unop(@_, "values") }
2282 sub pp_akeys { unop(@_, "keys") }
2283 sub pp_pop { unop(@_, "pop") }
2284 sub pp_shift { unop(@_, "shift") }
2286 sub pp_caller { unop(@_, "caller") }
2287 sub pp_reset { unop(@_, "reset") }
2288 sub pp_exit { unop(@_, "exit") }
2289 sub pp_prototype { unop(@_, "prototype") }
2291 sub pp_close { unop(@_, "close") }
2292 sub pp_fileno { unop(@_, "fileno") }
2293 sub pp_umask { unop(@_, "umask") }
2294 sub pp_untie { unop(@_, "untie") }
2295 sub pp_tied { unop(@_, "tied") }
2296 sub pp_dbmclose { unop(@_, "dbmclose") }
2297 sub pp_getc { unop(@_, "getc") }
2298 sub pp_eof { unop(@_, "eof") }
2299 sub pp_tell { unop(@_, "tell") }
2300 sub pp_getsockname { unop(@_, "getsockname") }
2301 sub pp_getpeername { unop(@_, "getpeername") }
2304 my ($self, $op, $cx) = @_;
2305 if (($op->flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS)) {
2306 my $kw = $self->keyword("chdir");
2307 my $kid = $self->const_sv($op->first)->PV;
2309 . ($cx >= 16 || $self->{'parens'} ? "($kid)" : " $kid");
2310 maybe_targmy(@_, sub { $_[3] }, $code);
2312 maybe_targmy(@_, \&unop, "chdir")
2316 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
2317 sub pp_readlink { unop(@_, "readlink") }
2318 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
2319 sub pp_readdir { unop(@_, "readdir") }
2320 sub pp_telldir { unop(@_, "telldir") }
2321 sub pp_rewinddir { unop(@_, "rewinddir") }
2322 sub pp_closedir { unop(@_, "closedir") }
2323 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
2324 sub pp_localtime { unop(@_, "localtime") }
2325 sub pp_gmtime { unop(@_, "gmtime") }
2326 sub pp_alarm { unop(@_, "alarm") }
2327 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
2330 my $code = unop(@_, "do", 1); # llafr does not apply
2331 if ($code =~ s/^((?:CORE::)?do) \{/$1({/) { $code .= ')' }
2337 $_[1]->private & OPpEVAL_BYTES ? 'evalbytes' : "eval"
2341 sub pp_ghbyname { unop(@_, "gethostbyname") }
2342 sub pp_gnbyname { unop(@_, "getnetbyname") }
2343 sub pp_gpbyname { unop(@_, "getprotobyname") }
2344 sub pp_shostent { unop(@_, "sethostent") }
2345 sub pp_snetent { unop(@_, "setnetent") }
2346 sub pp_sprotoent { unop(@_, "setprotoent") }
2347 sub pp_sservent { unop(@_, "setservent") }
2348 sub pp_gpwnam { unop(@_, "getpwnam") }
2349 sub pp_gpwuid { unop(@_, "getpwuid") }
2350 sub pp_ggrnam { unop(@_, "getgrnam") }
2351 sub pp_ggrgid { unop(@_, "getgrgid") }
2353 sub pp_lock { unop(@_, "lock") }
2355 sub pp_continue { unop(@_, "continue"); }
2356 sub pp_break { unop(@_, "break"); }
2360 my($op, $cx, $givwhen) = @_;
2362 my $enterop = $op->first;
2364 if ($enterop->flags & OPf_SPECIAL) {
2365 $head = $self->keyword("default");
2366 $block = $self->deparse($enterop->first, 0);
2369 my $cond = $enterop->first;
2370 my $cond_str = $self->deparse($cond, 1);
2371 $head = "$givwhen ($cond_str)";
2372 $block = $self->deparse($cond->sibling, 0);
2380 sub pp_leavegiven { givwhen(@_, $_[0]->keyword("given")); }
2381 sub pp_leavewhen { givwhen(@_, $_[0]->keyword("when")); }
2387 my $name = $self->keyword("exists");
2388 if ($op->private & OPpEXISTS_SUB) {
2389 # Checking for the existence of a subroutine
2390 return $self->maybe_parens_func($name,
2391 $self->pp_rv2cv($op->first, 16), $cx, 16);
2393 if ($op->flags & OPf_SPECIAL) {
2394 # Array element, not hash element
2395 return $self->maybe_parens_func($name,
2396 $self->pp_aelem($op->first, 16), $cx, 16);
2398 return $self->maybe_parens_func($name, $self->pp_helem($op->first, 16),
2406 my $name = $self->keyword("delete");
2407 if ($op->private & OPpSLICE) {
2408 if ($op->flags & OPf_SPECIAL) {
2409 # Deleting from an array, not a hash
2410 return $self->maybe_parens_func($name,
2411 $self->pp_aslice($op->first, 16),
2414 return $self->maybe_parens_func($name,
2415 $self->pp_hslice($op->first, 16),
2418 if ($op->flags & OPf_SPECIAL) {
2419 # Deleting from an array, not a hash
2420 return $self->maybe_parens_func($name,
2421 $self->pp_aelem($op->first, 16),
2424 return $self->maybe_parens_func($name,
2425 $self->pp_helem($op->first, 16),
2433 my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
2434 my $kid = $op->first;
2435 if ($kid->name eq 'const') {
2436 my $priv = $kid->private;
2437 my $sv = $self->const_sv($kid);
2439 if ($priv & OPpCONST_BARE) {
2443 } elsif ($priv & OPpCONST_NOVER) {
2444 $opname = $self->keyword('no');
2445 $arg = $self->const($sv, 16);
2446 } elsif ((my $tmp = $self->const($sv, 16)) =~ /^v/) {
2450 return $self->maybe_parens("$opname $arg", $cx, 16);
2456 1, # llafr does not apply
2463 my $kid = $op->first;
2464 if (not null $kid->sibling) {
2465 # XXX Was a here-doc
2466 return $self->dquote($op);
2468 $self->unop(@_, "scalar");
2475 return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
2478 sub anon_hash_or_list {
2482 my($pre, $post) = @{{"anonlist" => ["[","]"],
2483 "anonhash" => ["{","}"]}->{$op->name}};
2485 $op = $op->first->sibling; # skip pushmark
2486 for (; !null($op); $op = $op->sibling) {
2487 $expr = $self->deparse($op, 6);
2490 if ($pre eq "{" and $cx < 1) {
2491 # Disambiguate that it's not a block
2494 return $pre . join(", ", @exprs) . $post;
2500 if ($op->flags & OPf_SPECIAL) {
2501 return $self->anon_hash_or_list($op, $cx);
2503 warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL";
2507 *pp_anonhash = \&pp_anonlist;
2512 my $kid = $op->first;
2513 if ($kid->name eq "null") {
2514 my $anoncode = $kid = $kid->first;
2515 if ($anoncode->name eq "anoncode"
2516 or !null($anoncode = $kid->sibling) and
2517 $anoncode->name eq "anoncode") {
2518 return $self->e_anoncode({ code => $self->padval($anoncode->targ) });
2519 } elsif ($kid->name eq "pushmark") {
2520 my $sib_name = $kid->sibling->name;
2521 if ($sib_name eq 'entersub') {
2522 my $text = $self->deparse($kid->sibling, 1);
2523 # Always show parens for \(&func()), but only with -p otherwise
2524 $text = "($text)" if $self->{'parens'}
2525 or $kid->sibling->private & OPpENTERSUB_AMPER;
2530 local $self->{'in_refgen'} = 1;
2531 $self->pfixop($op, $cx, "\\", 20);
2535 my ($self, $info) = @_;
2536 my $text = $self->deparse_sub($info->{code});
2537 return $self->keyword("sub") . " $text";
2540 sub pp_srefgen { pp_refgen(@_) }
2545 my $kid = $op->first;
2546 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
2547 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
2548 return $self->unop($op, $cx, "readline");
2554 return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
2557 # Unary operators that can occur as pseudo-listops inside double quotes
2560 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
2562 if ($op->flags & OPf_KIDS) {
2564 # If there's more than one kid, the first is an ex-pushmark.
2565 $kid = $kid->sibling if not null $kid->sibling;
2566 return $self->maybe_parens_unop($name, $kid, $cx);
2568 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
2572 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
2573 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
2574 sub pp_uc { dq_unop(@_, "uc") }
2575 sub pp_lc { dq_unop(@_, "lc") }
2576 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
2577 sub pp_fc { dq_unop(@_, "fc") }
2581 my ($op, $cx, $name) = @_;
2582 if (class($op) eq "PVOP") {
2583 $name .= " " . $op->pv;
2584 } elsif (class($op) eq "OP") {
2586 } elsif (class($op) eq "UNOP") {
2587 (my $kid = $self->deparse($op->first, 7)) =~ s/^\cS//;
2588 # last foo() is a syntax error.
2589 $kid =~ /^(?!\d)\w/ and $kid = "($kid)";
2592 return $self->maybe_parens($name, $cx, 7);
2595 sub pp_last { loopex(@_, "last") }
2596 sub pp_next { loopex(@_, "next") }
2597 sub pp_redo { loopex(@_, "redo") }
2598 sub pp_goto { loopex(@_, "goto") }
2599 sub pp_dump { loopex(@_, "CORE::dump") }
2603 my($op, $cx, $name) = @_;
2604 if (class($op) eq "UNOP") {
2605 # Genuine '-X' filetests are exempt from the LLAFR, but not
2607 if ($name =~ /^-/) {
2608 (my $kid = $self->deparse($op->first, 16)) =~ s/^\cS//;
2609 return $self->maybe_parens("$name $kid", $cx, 16);
2611 return $self->maybe_parens_unop($name, $op->first, $cx);
2612 } elsif (class($op) =~ /^(SV|PAD)OP$/) {
2613 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
2614 } else { # I don't think baseop filetests ever survive ck_ftst, but...
2619 sub pp_lstat { ftst(@_, "lstat") }
2620 sub pp_stat { ftst(@_, "stat") }
2621 sub pp_ftrread { ftst(@_, "-R") }
2622 sub pp_ftrwrite { ftst(@_, "-W") }
2623 sub pp_ftrexec { ftst(@_, "-X") }
2624 sub pp_fteread { ftst(@_, "-r") }
2625 sub pp_ftewrite { ftst(@_, "-w") }
2626 sub pp_fteexec { ftst(@_, "-x") }
2627 sub pp_ftis { ftst(@_, "-e") }
2628 sub pp_fteowned { ftst(@_, "-O") }
2629 sub pp_ftrowned { ftst(@_, "-o") }
2630 sub pp_ftzero { ftst(@_, "-z") }
2631 sub pp_ftsize { ftst(@_, "-s") }
2632 sub pp_ftmtime { ftst(@_, "-M") }
2633 sub pp_ftatime { ftst(@_, "-A") }
2634 sub pp_ftctime { ftst(@_, "-C") }
2635 sub pp_ftsock { ftst(@_, "-S") }
2636 sub pp_ftchr { ftst(@_, "-c") }
2637 sub pp_ftblk { ftst(@_, "-b") }
2638 sub pp_ftfile { ftst(@_, "-f") }
2639 sub pp_ftdir { ftst(@_, "-d") }
2640 sub pp_ftpipe { ftst(@_, "-p") }
2641 sub pp_ftlink { ftst(@_, "-l") }
2642 sub pp_ftsuid { ftst(@_, "-u") }
2643 sub pp_ftsgid { ftst(@_, "-g") }
2644 sub pp_ftsvtx { ftst(@_, "-k") }
2645 sub pp_fttty { ftst(@_, "-t") }
2646 sub pp_fttext { ftst(@_, "-T") }
2647 sub pp_ftbinary { ftst(@_, "-B") }
2649 sub SWAP_CHILDREN () { 1 }
2650 sub ASSIGN () { 2 } # has OP= variant
2651 sub LIST_CONTEXT () { 4 } # Assignment is in list context
2657 my $name = $op->name;
2658 if ($name eq "concat" and $op->first->name eq "concat") {
2659 # avoid spurious '=' -- see comment in pp_concat
2662 if ($name eq "null" and class($op) eq "UNOP"
2663 and $op->first->name =~ /^(and|x?or)$/
2664 and null $op->first->sibling)
2666 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
2667 # with a null that's used as the common end point of the two
2668 # flows of control. For precedence purposes, ignore it.
2669 # (COND_EXPRs have these too, but we don't bother with
2670 # their associativity).
2671 return assoc_class($op->first);
2673 return $name . ($op->flags & OPf_STACKED ? "=" : "");
2676 # Left associative operators, like '+', for which
2677 # $a + $b + $c is equivalent to ($a + $b) + $c
2680 %left = ('multiply' => 19, 'i_multiply' => 19,
2681 'divide' => 19, 'i_divide' => 19,
2682 'modulo' => 19, 'i_modulo' => 19,
2684 'add' => 18, 'i_add' => 18,
2685 'subtract' => 18, 'i_subtract' => 18,
2687 'left_shift' => 17, 'right_shift' => 17,
2689 'bit_or' => 12, 'bit_xor' => 12,
2691 'or' => 2, 'xor' => 2,
2695 sub deparse_binop_left {
2697 my($op, $left, $prec) = @_;
2698 if ($left{assoc_class($op)} && $left{assoc_class($left)}
2699 and $left{assoc_class($op)} == $left{assoc_class($left)})
2701 return $self->deparse($left, $prec - .00001);
2703 return $self->deparse($left, $prec);
2707 # Right associative operators, like '=', for which
2708 # $a = $b = $c is equivalent to $a = ($b = $c)
2711 %right = ('pow' => 22,
2712 'sassign=' => 7, 'aassign=' => 7,
2713 'multiply=' => 7, 'i_multiply=' => 7,
2714 'divide=' => 7, 'i_divide=' => 7,
2715 'modulo=' => 7, 'i_modulo=' => 7,
2716 'repeat=' => 7, 'refassign' => 7, 'refassign=' => 7,
2717 'add=' => 7, 'i_add=' => 7,
2718 'subtract=' => 7, 'i_subtract=' => 7,
2720 'left_shift=' => 7, 'right_shift=' => 7,
2722 'bit_or=' => 7, 'bit_xor=' => 7,
2728 sub deparse_binop_right {
2730 my($op, $right, $prec) = @_;
2731 if ($right{assoc_class($op)} && $right{assoc_class($right)}
2732 and $right{assoc_class($op)} == $right{assoc_class($right)})
2734 return $self->deparse($right, $prec - .00001);
2736 return $self->deparse($right, $prec);
2742 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
2743 my $left = $op->first;
2744 my $right = $op->last;
2746 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
2750 if ($flags & SWAP_CHILDREN) {
2751 ($left, $right) = ($right, $left);
2754 $left = $self->deparse_binop_left($op, $left, $prec);
2755 $left = "($left)" if $flags & LIST_CONTEXT
2756 and $left !~ /^(my|our|local|)[\@\(]/
2758 # Parenthesize if the left argument is a
2760 my $left = $leftop->first->sibling;
2761 $left->name eq 'repeat'
2762 && null($left->sibling);
2764 $right = $self->deparse_binop_right($op, $right, $prec);
2765 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
2768 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2769 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2770 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
2771 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2772 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2773 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2774 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2775 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
2776 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2777 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2778 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
2780 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
2781 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
2782 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
2783 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
2784 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
2786 sub pp_eq { binop(@_, "==", 14) }
2787 sub pp_ne { binop(@_, "!=", 14) }
2788 sub pp_lt { binop(@_, "<", 15) }
2789 sub pp_gt { binop(@_, ">", 15) }
2790 sub pp_ge { binop(@_, ">=", 15) }
2791 sub pp_le { binop(@_, "<=", 15) }
2792 sub pp_ncmp { binop(@_, "<=>", 14) }
2793 sub pp_i_eq { binop(@_, "==", 14) }
2794 sub pp_i_ne { binop(@_, "!=", 14) }
2795 sub pp_i_lt { binop(@_, "<", 15) }
2796 sub pp_i_gt { binop(@_, ">", 15) }
2797 sub pp_i_ge { binop(@_, ">=", 15) }
2798 sub pp_i_le { binop(@_, "<=", 15) }
2799 sub pp_i_ncmp { binop(@_, "<=>", 14) }
2801 sub pp_seq { binop(@_, "eq", 14) }
2802 sub pp_sne { binop(@_, "ne", 14) }
2803 sub pp_slt { binop(@_, "lt", 15) }
2804 sub pp_sgt { binop(@_, "gt", 15) }
2805 sub pp_sge { binop(@_, "ge", 15) }
2806 sub pp_sle { binop(@_, "le", 15) }
2807 sub pp_scmp { binop(@_, "cmp", 14) }
2809 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
2810 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
2813 my ($self, $op, $cx) = @_;
2814 if ($op->flags & OPf_SPECIAL) {
2815 return $self->deparse($op->last, $cx);
2818 binop(@_, "~~", 14);
2822 # '.' is special because concats-of-concats are optimized to save copying
2823 # by making all but the first concat stacked. The effect is as if the
2824 # programmer had written '($a . $b) .= $c', except legal.
2825 sub pp_concat { maybe_targmy(@_, \&real_concat) }
2829 my $left = $op->first;
2830 my $right = $op->last;
2833 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
2837 $left = $self->deparse_binop_left($op, $left, $prec);
2838 $right = $self->deparse_binop_right($op, $right, $prec);
2839 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
2842 sub pp_repeat { maybe_targmy(@_, \&repeat) }
2844 # 'x' is weird when the left arg is a list
2848 my $left = $op->first;
2849 my $right = $op->last;
2852 if ($op->flags & OPf_STACKED) {
2856 if (null($right)) { # list repeat; count is inside left-side ex-list
2857 # in 5.21.5 and earlier
2858 my $kid = $left->first->sibling; # skip pushmark
2860 for (; !null($kid->sibling); $kid = $kid->sibling) {
2861 push @exprs, $self->deparse($kid, 6);
2864 $left = "(" . join(", ", @exprs). ")";
2866 my $dolist = $op->private & OPpREPEAT_DOLIST;
2867 $left = $self->deparse_binop_left($op, $left, $dolist ? 1 : $prec);
2872 $right = $self->deparse_binop_right($op, $right, $prec);
2873 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
2878 my ($op, $cx, $type) = @_;
2879 my $left = $op->first;
2880 my $right = $left->sibling;
2881 $left = $self->deparse($left, 9);
2882 $right = $self->deparse($right, 9);
2883 return $self->maybe_parens("$left $type $right", $cx, 9);
2889 my $flip = $op->first;
2890 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
2891 return $self->range($flip->first, $cx, $type);
2894 # one-line while/until is handled in pp_leave
2898 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
2899 my $left = $op->first;
2900 my $right = $op->first->sibling;
2901 $blockname &&= $self->keyword($blockname);
2902 if ($cx < 1 and is_scope($right) and $blockname
2903 and $self->{'expand'} < 7)
2905 $left = $self->deparse($left, 1);
2906 $right = $self->deparse($right, 0);
2907 return "$blockname ($left) {\n\t$right\n\b}\cK";
2908 } elsif ($cx < 1 and $blockname and not $self->{'parens'}
2909 and $self->{'expand'} < 7) { # $b if $a
2910 $right = $self->deparse($right, 1);
2911 $left = $self->deparse($left, 1);
2912 return "$right $blockname $left";
2913 } elsif ($cx > $lowprec and $highop) { # $a && $b
2914 $left = $self->deparse_binop_left($op, $left, $highprec);
2915 $right = $self->deparse_binop_right($op, $right, $highprec);
2916 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
2917 } else { # $a and $b
2918 $left = $self->deparse_binop_left($op, $left, $lowprec);
2919 $right = $self->deparse_binop_right($op, $right, $lowprec);
2920 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
2924 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
2925 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
2926 sub pp_dor { logop(@_, "//", 10) }
2928 # xor is syntactically a logop, but it's really a binop (contrary to
2929 # old versions of opcode.pl). Syntax is what matters here.
2930 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
2934 my ($op, $cx, $opname) = @_;
2935 my $left = $op->first;
2936 my $right = $op->first->sibling->first; # skip sassign
2937 $left = $self->deparse($left, 7);
2938 $right = $self->deparse($right, 7);
2939 return $self->maybe_parens("$left $opname $right", $cx, 7);
2942 sub pp_andassign { logassignop(@_, "&&=") }
2943 sub pp_orassign { logassignop(@_, "||=") }
2944 sub pp_dorassign { logassignop(@_, "//=") }
2946 sub rv2gv_or_string {
2948 if ($op->name eq "gv") { # could be open("open") or open("###")
2950 $self->stash_variable_name("", $self->gv_or_padgv($op));
2951 $quoted ? $name : "*$name";
2954 $self->deparse($op, 6);
2960 my($op, $cx, $name, $kid, $nollafr) = @_;
2962 my $parens = ($cx >= 5) || $self->{'parens'};
2963 $kid ||= $op->first->sibling;
2964 # If there are no arguments, add final parentheses (or parenthesize the
2965 # whole thing if the llafr does not apply) to account for cases like
2966 # (return)+1 or setpgrp()+1. When the llafr does not apply, we use a
2967 # precedence of 6 (< comma), as "return, 1" does not need parentheses.
2970 ? $self->maybe_parens($self->keyword($name), $cx, 7)
2971 : $self->keyword($name) . '()' x (7 < $cx);
2974 my $fullname = $self->keyword($name);
2975 my $proto = prototype("CORE::$name");
2977 ( (defined $proto && $proto =~ /^;?\*/)
2978 || $name eq 'select' # select(F) doesn't have a proto
2980 && $kid->name eq "rv2gv"
2981 && !($kid->private & OPpLVAL_INTRO)
2983 $first = $self->rv2gv_or_string($kid->first);
2986 $first = $self->deparse($kid, 6);
2988 if ($name eq "chmod" && $first =~ /^\d+$/) {
2989 $first = sprintf("%#o", $first);
2992 if not $parens and not $nollafr and substr($first, 0, 1) eq "(";
2993 push @exprs, $first;
2994 $kid = $kid->sibling;
2995 if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv"
2996 && !($kid->private & OPpLVAL_INTRO)) {
2997 push @exprs, $first = $self->rv2gv_or_string($kid->first);
2998 $kid = $kid->sibling;
3000 for (; !null($kid); $kid = $kid->sibling) {
3001 push @exprs, $self->deparse($kid, 6);
3003 if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) {
3004 return "$exprs[0] = $fullname"
3005 . ($parens ? "($exprs[0])" : " $exprs[0]");
3008 if ($parens && $nollafr) {
3009 return "($fullname " . join(", ", @exprs) . ")";
3011 return "$fullname(" . join(", ", @exprs) . ")";
3013 return "$fullname " . join(", ", @exprs);
3017 sub pp_bless { listop(@_, "bless") }
3018 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
3020 my ($self,$op,$cx) = @_;
3021 if ($op->private & OPpSUBSTR_REPL_FIRST) {
3023 listop($self, $op, 7, "substr", $op->first->sibling->sibling)
3025 . $self->deparse($op->first->sibling, 7);
3027 maybe_local(@_, listop(@_, "substr"))
3029 sub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) }
3030 sub pp_index { maybe_targmy(@_, \&listop, "index") }
3031 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
3032 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
3033 sub pp_formline { listop(@_, "formline") } # see also deparse_format
3034 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
3035 sub pp_unpack { listop(@_, "unpack") }
3036 sub pp_pack { listop(@_, "pack") }
3037 sub pp_join { maybe_targmy(@_, \&listop, "join") }
3038 sub pp_splice { listop(@_, "splice") }
3039 sub pp_push { maybe_targmy(@_, \&listop, "push") }
3040 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
3041 sub pp_reverse { listop(@_, "reverse") }
3042 sub pp_warn { listop(@_, "warn") }
3043 sub pp_die { listop(@_, "die") }
3044 sub pp_return { listop(@_, "return", undef, 1) } # llafr does not apply
3045 sub pp_open { listop(@_, "open") }
3046 sub pp_pipe_op { listop(@_, "pipe") }
3047 sub pp_tie { listop(@_, "tie") }
3048 sub pp_binmode { listop(@_, "binmode") }
3049 sub pp_dbmopen { listop(@_, "dbmopen") }
3050 sub pp_sselect { listop(@_, "select") }
3051 sub pp_select { listop(@_, "select") }
3052 sub pp_read { listop(@_, "read") }
3053 sub pp_sysopen { listop(@_, "sysopen") }
3054 sub pp_sysseek { listop(@_, "sysseek") }
3055 sub pp_sysread { listop(@_, "sysread") }
3056 sub pp_syswrite { listop(@_, "syswrite") }
3057 sub pp_send { listop(@_, "send") }
3058 sub pp_recv { listop(@_, "recv") }
3059 sub pp_seek { listop(@_, "seek") }
3060 sub pp_fcntl { listop(@_, "fcntl") }
3061 sub pp_ioctl { listop(@_, "ioctl") }
3062 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
3063 sub pp_socket { listop(@_, "socket") }
3064 sub pp_sockpair { listop(@_, "socketpair") }
3065 sub pp_bind { listop(@_, "bind") }
3066 sub pp_connect { listop(@_, "connect") }
3067 sub pp_listen { listop(@_, "listen") }
3068 sub pp_accept { listop(@_, "accept") }
3069 sub pp_shutdown { listop(@_, "shutdown") }
3070 sub pp_gsockopt { listop(@_, "getsockopt") }
3071 sub pp_ssockopt { listop(@_, "setsockopt") }
3072 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
3073 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
3074 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
3075 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
3076 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
3077 sub pp_link { maybe_targmy(@_, \&listop, "link") }
3078 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
3079 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
3080 sub pp_open_dir { listop(@_, "opendir") }
3081 sub pp_seekdir { listop(@_, "seekdir") }
3082 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
3083 sub pp_system { maybe_targmy(@_, \&indirop, "system") }
3084 sub pp_exec { maybe_targmy(@_, \&indirop, "exec") }
3085 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
3086 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
3087 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
3088 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
3089 sub pp_shmget { listop(@_, "shmget") }
3090 sub pp_shmctl { listop(@_, "shmctl") }
3091 sub pp_shmread { listop(@_, "shmread") }
3092 sub pp_shmwrite { listop(@_, "shmwrite") }
3093 sub pp_msgget { listop(@_, "msgget") }
3094 sub pp_msgctl { listop(@_, "msgctl") }
3095 sub pp_msgsnd { listop(@_, "msgsnd") }
3096 sub pp_msgrcv { listop(@_, "msgrcv") }
3097 sub pp_semget { listop(@_, "semget") }
3098 sub pp_semctl { listop(@_, "semctl") }
3099 sub pp_semop { listop(@_, "semop") }
3100 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
3101 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
3102 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
3103 sub pp_gsbyname { listop(@_, "getservbyname") }
3104 sub pp_gsbyport { listop(@_, "getservbyport") }
3105 sub pp_syscall { listop(@_, "syscall") }
3110 my $kid = $op->first->sibling; # skip pushmark
3112 $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
3114 if ($keyword =~ /^CORE::/
3115 or $kid->name ne 'const'
3116 or ($text = $self->dq($kid))
3117 =~ /^\$?(\w|::|\`)+$/ # could look like a readline
3118 or $text =~ /[<>]/) {
3119 $text = $self->deparse($kid);
3120 return $cx >= 5 || $self->{'parens'}
3124 return '<' . $text . '>';
3128 # Truncate is special because OPf_SPECIAL makes a bareword first arg
3129 # be a filehandle. This could probably be better fixed in the core
3130 # by moving the GV lookup into ck_truc.
3136 my $parens = ($cx >= 5) || $self->{'parens'};
3137 my $kid = $op->first->sibling;
3139 if ($op->flags & OPf_SPECIAL) {
3140 # $kid is an OP_CONST
3141 $fh = $self->const_sv($kid)->PV;
3143 $fh = $self->deparse($kid, 6);
3144 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
3146 my $len = $self->deparse($kid->sibling, 6);
3147 my $name = $self->keyword('truncate');
3149 return "$name($fh, $len)";
3151 return "$name $fh, $len";
3157 my($op, $cx, $name) = @_;
3159 my $firstkid = my $kid = $op->first->sibling;
3161 if ($op->flags & OPf_STACKED) {
3163 $indir = $indir->first; # skip rv2gv
3164 if (is_scope($indir)) {
3165 $indir = "{" . $self->deparse($indir, 0) . "}";
3166 $indir = "{;}" if $indir eq "{}";
3167 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
3168 $indir = $self->const_sv($indir)->PV;
3170 $indir = $self->deparse($indir, 24);
3172 $indir = $indir . " ";
3173 $kid = $kid->sibling;
3175 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
3176 $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
3179 elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
3180 $indir = '{$b cmp $a} ';
3182 for (; !null($kid); $kid = $kid->sibling) {
3183 $expr = $self->deparse($kid, !$indir && $kid == $firstkid && $name eq "sort" && $firstkid->name eq "entersub" ? 16 : 6);
3187 if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
3188 $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort');
3190 else { $name2 = $self->keyword($name) }
3191 if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
3192 return "$exprs[0] = $name2 $indir $exprs[0]";
3195 my $args = $indir . join(", ", @exprs);
3196 if ($indir ne "" && $name eq "sort") {
3197 # We don't want to say "sort(f 1, 2, 3)", since perl -w will
3198 # give bareword warnings in that case. Therefore if context
3199 # requires, we'll put parens around the outside "(sort f 1, 2,
3200 # 3)". Unfortunately, we'll currently think the parens are
3201 # necessary more often that they really are, because we don't
3202 # distinguish which side of an assignment we're on.
3204 return "($name2 $args)";
3206 return "$name2 $args";
3209 !$indir && $name eq "sort"
3210 && !null($op->first->sibling)
3211 && $op->first->sibling->name eq 'entersub'
3213 # We cannot say sort foo(bar), as foo will be interpreted as a
3214 # comparison routine. We have to say sort(...) in that case.
3215 return "$name2($args)";
3218 ? $self->maybe_parens_func($name2, $args, $cx, 5)
3219 : $name2 . '()' x (7 < $cx);
3224 sub pp_prtf { indirop(@_, "printf") }
3225 sub pp_print { indirop(@_, "print") }
3226 sub pp_say { indirop(@_, "say") }
3227 sub pp_sort { indirop(@_, "sort") }
3231 my($op, $cx, $name) = @_;
3233 my $kid = $op->first; # this is the (map|grep)start
3234 $kid = $kid->first->sibling; # skip a pushmark
3235 my $code = $kid->first; # skip a null
3236 if (is_scope $code) {
3237 $code = "{" . $self->deparse($code, 0) . "} ";
3239 $code = $self->deparse($code, 24);
3240 $code .= ", " if !null($kid->sibling);
3242 $kid = $kid->sibling;
3243 for (; !null($kid); $kid = $kid->sibling) {
3244 $expr = $self->deparse($kid, 6);
3245 push @exprs, $expr if defined $expr;
3247 return $self->maybe_parens_func($self->keyword($name),
3248 $code . join(", ", @exprs), $cx, 5);
3251 sub pp_mapwhile { mapop(@_, "map") }
3252 sub pp_grepwhile { mapop(@_, "grep") }
3253 sub pp_mapstart { baseop(@_, "map") }
3254 sub pp_grepstart { baseop(@_, "grep") }
3259 eval { require B::Op_private }
3260 ? @{$B::Op_private::ops_using{OPpLVAL_INTRO}}
3261 : qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice
3262 hslice delete padsv padav padhv enteriter entersub padrange
3263 pushmark cond_expr refassign list)
3265 delete @uses_intro{qw( lvref lvrefslice lvavref entersub )};
3272 my $kid = $op->first->sibling; # skip pushmark
3273 return '' if class($kid) eq 'NULL';
3275 my $local = "either"; # could be local(...), my(...), state(...) or our(...)
3277 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
3278 my $lopname = $lop->name;
3279 my $loppriv = $lop->private;
3281 if ($lopname =~ /^pad[ash]v$/ && $loppriv & OPpLVAL_INTRO) {
3282 if ($loppriv & OPpPAD_STATE) { # state()
3283 ($local = "", last) if $local !~ /^(?:either|state)$/;
3286 ($local = "", last) if $local !~ /^(?:either|my)$/;
3289 my $padname = $self->padname_sv($lop->targ);
3290 if ($padname->FLAGS & SVpad_TYPED) {
3291 $newtype = $padname->SvSTASH->NAME;
3293 } elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/
3294 && $loppriv & OPpOUR_INTRO
3295 or $lopname eq "null" && class($lop) eq 'UNOP'
3296 && $lop->first->name eq "gvsv"
3297 && $lop->first->private & OPpOUR_INTRO) { # our()
3298 my $newlocal = "local " x !!($loppriv & OPpLVAL_INTRO) . "our";
3300 if $local ne 'either' && $local ne $newlocal;
3302 my $funny = !$1 || $1 eq 's' ? '$' : $1 eq 'a' ? '@' : '%';
3303 if (my $t = $self->find_our_type(
3304 $funny . $self->gv_or_padgv($lop->first)->NAME
3308 } elsif ($lopname ne 'undef'
3309 and !($loppriv & OPpLVAL_INTRO)
3310 || !exists $uses_intro{$lopname eq 'null'
3311 ? substr B::ppname($lop->targ), 3
3314 $local = ""; # or not
3316 } elsif ($lopname ne "undef")
3319 ($local = "", last) if $local !~ /^(?:either|local)$/;
3322 if (defined $type && defined $newtype && $newtype ne $type) {
3328 $local = "" if $local eq "either"; # no point if it's all undefs
3329 $local &&= join ' ', map $self->keyword($_), split / /, $local;
3330 $local .= " $type " if $local && length $type;
3331 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
3332 for (; !null($kid); $kid = $kid->sibling) {
3334 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
3339 $self->{'avoid_local'}{$$lop}++;
3340 $expr = $self->deparse($kid, 6);
3341 delete $self->{'avoid_local'}{$$lop};
3343 $expr = $self->deparse($kid, 6);
3348 return "$local(" . join(", ", @exprs) . ")";
3350 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
3354 sub is_ifelse_cont {
3356 return ($op->name eq "null" and class($op) eq "UNOP"
3357 and $op->first->name =~ /^(and|cond_expr)$/
3358 and is_scope($op->first->first->sibling));
3364 my $cond = $op->first;
3365 my $true = $cond->sibling;
3366 my $false = $true->sibling;
3367 my $cuddle = $self->{'cuddle'};
3368 unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
3369 (is_scope($false) || is_ifelse_cont($false))
3370 and $self->{'expand'} < 7) {
3371 $cond = $self->deparse($cond, 8);
3372 $true = $self->deparse($true, 6);
3373 $false = $self->deparse($false, 8);
3374 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
3377 $cond = $self->deparse($cond, 1);
3378 $true = $self->deparse($true, 0);
3379 my $head = $self->keyword("if") . " ($cond) {\n\t$true\n\b}";
3382 while (!null($false) and is_ifelse_cont($false)) {
3383 my $newop = $false->first;
3384 my $newcond = $newop->first;
3385 my $newtrue = $newcond->sibling;
3386 $false = $newtrue->sibling; # last in chain is OP_AND => no else
3387 if ($newcond->name eq "lineseq")
3389 # lineseq to ensure correct line numbers in elsif()
3390 # Bug #37302 fixed by change #33710.
3391 $newcond = $newcond->first->sibling;
3393 $newcond = $self->deparse($newcond, 1);
3394 $newtrue = $self->deparse($newtrue, 0);
3395 $elsif ||= $self->keyword("elsif");
3396 push @elsifs, "$elsif ($newcond) {\n\t$newtrue\n\b}";
3398 if (!null($false)) {
3399 $false = $cuddle . $self->keyword("else") . " {\n\t" .
3400 $self->deparse($false, 0) . "\n\b}\cK";
3404 return $head . join($cuddle, "", @elsifs) . $false;
3408 my ($self, $op, $cx) = @_;
3409 my $cond = $op->first;
3410 my $true = $cond->sibling;
3412 my $ret = $self->deparse($true, $cx);
3413 $ret =~ s/^(\(?)\$/$1 . $self->keyword("state") . ' $'/e;
3419 my($op, $cx, $init) = @_;
3420 my $enter = $op->first;
3421 my $kid = $enter->sibling;
3422 local(@$self{qw'curstash warnings hints hinthash'})
3423 = @$self{qw'curstash warnings hints hinthash'};
3429 if ($kid->name eq "lineseq") { # bare or infinite loop
3430 if ($kid->last->name eq "unstack") { # infinite
3431 $head = "while (1) "; # Can't use for(;;) if there's a continue
3437 } elsif ($enter->name eq "enteriter") { # foreach
3438 my $ary = $enter->first->sibling; # first was pushmark
3439 my $var = $ary->sibling;
3440 if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
3441 # "reverse" was optimised away
3442 $ary = listop($self, $ary->first->sibling, 1, 'reverse');
3443 } elsif ($enter->flags & OPf_STACKED
3444 and not null $ary->first->sibling->sibling)
3446 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
3447 $self->deparse($ary->first->sibling->sibling, 9);
3449 $ary = $self->deparse($ary, 1);
3452 $var = $self->pp_padsv($enter, 1, 1);
3453 } elsif ($var->name eq "rv2gv") {
3454 $var = $self->pp_rv2sv($var, 1);
3455 if ($enter->private & OPpOUR_INTRO) {
3456 # our declarations don't have package names
3457 $var =~ s/^(.).*::/$1/;
3460 } elsif ($var->name eq "gv") {
3461 $var = "\$" . $self->deparse($var, 1);
3463 $var = $self->deparse($var, 1);
3465 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
3466 if (!is_state $body->first and $body->first->name !~ /^(?:stub|leave|scope)$/) {
3467 confess unless $var eq '$_';
3468 $body = $body->first;
3469 return $self->deparse($body, 2) . " "
3470 . $self->keyword("foreach") . " ($ary)";
3472 $head = "foreach $var ($ary) ";
3473 } elsif ($kid->name eq "null") { # while/until
3475 $name = {"and" => "while", "or" => "until"}->{$kid->name};
3476 $cond = $kid->first;
3477 $body = $kid->first->sibling;
3478 } elsif ($kid->name eq "stub") { # bare and empty
3479 return "{;}"; # {} could be a hashref
3481 # If there isn't a continue block, then the next pointer for the loop
3482 # will point to the unstack, which is kid's last child, except
3483 # in a bare loop, when it will point to the leaveloop. When neither of
3484 # these conditions hold, then the second-to-last child is the continue
3485 # block (or the last in a bare loop).
3486 my $cont_start = $enter->nextop;
3490 if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
3492 $cont = $body->last;
3494 $cont = $body->first;
3495 while (!null($cont->sibling->sibling)) {
3496 $cont = $cont->sibling;
3499 my $state = $body->first;
3500 my $cuddle = $self->{'cuddle'};
3502 for (; $$state != $$cont; $state = $state->sibling) {
3503 push @states, $state;
3505 $body = $self->lineseq(undef, 0, @states);
3506 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
3507 $precond = "for ($init; ";
3508 $postcond = "; " . $self->deparse($cont, 1) .") ";
3511 $cont = $cuddle . "continue {\n\t" .
3512 $self->deparse($cont, 0) . "\n\b}\cK";
3515 return "" if !defined $body;
3517 $precond = "for ($init; ";
3521 $body = $self->deparse($body, 0);
3523 if ($precond) { # for(;;)
3524 $cond &&= $name eq 'until'
3525 ? listop($self, undef, 1, "not", $cond->first)
3526 : $self->deparse($cond, 1);
3527 $head = "$precond$cond$postcond";
3529 if ($name && !$head) {
3530 ref $cond and $cond = $self->deparse($cond, 1);
3531 $head = "$name ($cond) ";
3533 $head =~ s/^(for(?:each)?|while|until)/$self->keyword($1)/e;
3534 $body =~ s/;?$/;\n/;
3536 return $head . "{\n\t" . $body . "\b}" . $cont;
3539 sub pp_leaveloop { shift->loop_common(@_, "") }
3544 my $init = $self->deparse($op, 1);
3545 my $s = $op->sibling;
3546 my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling;
3547 return $self->loop_common($ll, $cx, $init);
3552 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
3556 my ($op, $expect_type) = @_;
3557 my $type = $op->type;
3558 return($type == $expect_type
3559 || ($type == OP_NULL && $op->targ == $expect_type));
3563 my($self, $op, $cx) = @_;
3564 if (class($op) eq "OP") {
3566 return $self->{'ex_const'} if $op->targ == OP_CONST;
3567 } elsif (class ($op) eq "COP") {
3568 return &pp_nextstate;
3569 } elsif ($op->first->name eq 'pushmark'
3570 or $op->first->name eq 'null'
3571 && $op->first->targ == OP_PUSHMARK
3572 && _op_is_or_was($op, OP_LIST)) {
3573 return $self->pp_list($op, $cx);
3574 } elsif ($op->first->name eq "enter") {
3575 return $self->pp_leave($op, $cx);
3576 } elsif ($op->first->name eq "leave") {
3577 return $self->pp_leave($op->first, $cx);
3578 } elsif ($op->first->name eq "scope") {
3579 return $self->pp_scope($op->first, $cx);
3580 } elsif ($op->targ == OP_STRINGIFY) {
3581 return $self->dquote($op, $cx);
3582 } elsif ($op->targ == OP_GLOB) {
3583 return $self->pp_glob(
3584 $op->first # entersub
3590 } elsif (!null($op->first->sibling) and
3591 $op->first->sibling->name eq "readline" and
3592 $op->first->sibling->flags & OPf_STACKED) {
3593 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
3594 . $self->deparse($op->first->sibling, 7),
3596 } elsif (!null($op->first->sibling) and
3597 $op->first->sibling->name =~ /^transr?\z/ and
3598 $op->first->sibling->flags & OPf_STACKED) {
3599 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
3600 . $self->deparse($op->first->sibling, 20),
3602 } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
3603 return ($self->lex_in_scope("&do") ? "CORE::do" : "do")
3604 . " {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
3605 } elsif (!null($op->first->sibling) and
3606 $op->first->sibling->name eq "null" and
3607 class($op->first->sibling) eq "UNOP" and
3608 $op->first->sibling->first->flags & OPf_STACKED and
3609 $op->first->sibling->first->name eq "rcatline") {
3610 return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
3611 . $self->deparse($op->first->sibling, 18),
3614 return $self->deparse($op->first, $cx);
3621 return $self->padname_sv($targ)->PVX;
3627 return substr($self->padname($op->targ), 1); # skip $/@/%
3632 my($op, $cx, $forbid_parens) = @_;
3633 my $targ = $op->targ;
3634 return $self->maybe_my($op, $cx, $self->padname($targ),
3635 $self->padname_sv($targ),
3639 sub pp_padav { pp_padsv(@_) }
3640 sub pp_padhv { pp_padsv(@_) }
3645 if (class($op) eq "PADOP") {
3646 return $self->padval($op->padix);
3647 } else { # class($op) eq "SVOP"
3655 my $gv = $self->gv_or_padgv($op);
3656 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
3657 $self->gv_name($gv), $cx));
3663 my $gv = $self->gv_or_padgv($op);
3664 return $self->gv_name($gv);
3667 sub pp_aelemfast_lex {
3670 my $name = $self->padname($op->targ);
3672 my $i = $op->private;
3673 $i -= 256 if $i > 127;
3674 return $name . "[" . ($i + $self->{'arybase'}) . "]";
3680 # optimised PADAV, pre 5.15
3681 return $self->pp_aelemfast_lex(@_) if ($op->flags & OPf_SPECIAL);
3683 my $gv = $self->gv_or_padgv($op);
3684 my($name,$quoted) = $self->stash_variable_name('@',$gv);
3685 $name = $quoted ? "$name->" : '$' . $name;
3686 my $i = $op->private;
3687 $i -= 256 if $i > 127;
3688 return $name . "[" . ($i + $self->{'arybase'}) . "]";
3693 my($op, $cx, $type) = @_;
3695 if (class($op) eq 'NULL' || !$op->can("first")) {
3696 carp("Unexpected op in pp_rv2x");
3699 my $kid = $op->first;
3700 if ($kid->name eq "gv") {
3701 return $self->stash_variable($type, $self->deparse($kid, 0), $cx);
3702 } elsif (is_scalar $kid) {
3703 my $str = $self->deparse($kid, 0);
3704 if ($str =~ /^\$([^\w\d])\z/) {
3705 # "$$+" isn't a legal way to write the scalar dereference
3706 # of $+, since the lexer can't tell you aren't trying to
3707 # do something like "$$ + 1" to get one more than your
3708 # PID. Either "${$+}" or "$${+}" are workable
3709 # disambiguations, but if the programmer did the former,
3710 # they'd be in the "else" clause below rather than here.
3711 # It's not clear if this should somehow be unified with
3712 # the code in dq and re_dq that also adds lexer
3713 # disambiguation braces.
3714 $str = '$' . "{$1}"; #'
3716 return $type . $str;
3718 return $type . "{" . $self->deparse($kid, 0) . "}";
3722 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
3723 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
3724 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
3730 if ($op->first->name eq "padav") {
3731 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
3733 return $self->maybe_local($op, $cx,
3734 $self->rv2x($op->first, $cx, '$#'));
3738 # skip down to the old, ex-rv2cv
3740 my ($self, $op, $cx) = @_;
3741 if (!null($op->first) && $op->first->name eq 'null' &&
3742 $op->first->targ == OP_LIST)
3744 return $self->rv2x($op->first->first->sibling, $cx, "&")
3747 return $self->rv2x($op, $cx, "")
3753 my($cx, @list) = @_;
3754 my @a = map $self->const($_, 6), @list;
3759 } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
3760 # collapse (-1,0,1,2) into (-1..2)
3761 my ($s, $e) = @a[0,-1];
3763 return $self->maybe_parens("$s..$e", $cx, 9)
3764 unless grep $i++ != $_, @a;
3766 return $self->maybe_parens(join(", ", @a), $cx, 6);
3772 my $kid = $op->first;
3773 if ($kid->name eq "const") { # constant list
3774 my $av = $self->const_sv($kid);
3775 return $self->list_const($cx, $av->ARRAY);
3777 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
3781 sub is_subscriptable {
3783 if ($op->name =~ /^([ahg]elem|multideref$)/) {
3785 } elsif ($op->name eq "entersub") {
3786 my $kid = $op->first;
3787 return 0 unless null $kid->sibling;
3789 $kid = $kid->sibling until null $kid->sibling;
3790 return 0 if is_scope($kid);
3792 return 0 if $kid->name eq "gv" || $kid->name eq "padcv";
3793 return 0 if is_scalar($kid);
3794 return is_subscriptable($kid);
3800 sub elem_or_slice_array_name
3803 my ($array, $left, $padname, $allow_arrow) = @_;
3805 if ($array->name eq $padname) {
3806 return $self->padany($array);
3807 } elsif (is_scope($array)) { # ${expr}[0]
3808 return "{" . $self->deparse($array, 0) . "}";
3809 } elsif ($array->name eq "gv") {
3810 ($array, my $quoted) =
3811 $self->stash_variable_name(
3812 $left eq '[' ? '@' : '%', $self->gv_or_padgv($array)
3814 if (!$allow_arrow && $quoted) {
3815 # This cannot happen.
3816 die "Invalid variable name $array for slice";
3818 return $quoted ? "$array->" : $array;
3819 } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
3820 return $self->deparse($array, 24);
3826 sub elem_or_slice_single_index
3831 $idx = $self->deparse($idx, 1);
3833 # Outer parens in an array index will confuse perl
3834 # if we're interpolating in a regular expression, i.e.
3835 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
3837 # If $self->{parens}, then an initial '(' will
3838 # definitely be paired with a final ')'. If
3839 # !$self->{parens}, the misleading parens won't
3840 # have been added in the first place.
3842 # [You might think that we could get "(...)...(...)"
3843 # where the initial and final parens do not match
3844 # each other. But we can't, because the above would
3845 # only happen if there's an infix binop between the
3846 # two pairs of parens, and *that* means that the whole
3847 # expression would be parenthesized as well.]
3849 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
3851 # Hash-element braces will autoquote a bareword inside themselves.
3852 # We need to make sure that C<$hash{warn()}> doesn't come out as
3853 # C<$hash{warn}>, which has a quite different meaning. Currently
3854 # B::Deparse will always quote strings, even if the string was a
3855 # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
3856 # for constant strings.) So we can cheat slightly here - if we see
3857 # a bareword, we know that it is supposed to be a function call.
3859 $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
3866 my ($op, $cx, $left, $right, $padname) = @_;
3867 my($array, $idx) = ($op->first, $op->first->sibling);
3869 $idx = $self->elem_or_slice_single_index($idx);
3871 unless ($array->name eq $padname) { # Maybe this has been fixed
3872 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
3874 if (my $array_name=$self->elem_or_slice_array_name
3875 ($array, $left, $padname, 1)) {
3876 return ($array_name =~ /->\z/
3878 : $array_name eq '#' ? '${#}' : "\$" . $array_name)
3879 . $left . $idx . $right;
3881 # $x[20][3]{hi} or expr->[20]
3882 my $arrow = is_subscriptable($array) ? "" : "->";
3883 return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
3888 # a simplified version of elem_or_slice_array_name()
3889 # for the use of pp_multideref
3891 sub multideref_var_name {
3893 my ($gv, $is_hash) = @_;
3895 my ($name, $quoted) =
3896 $self->stash_variable_name( $is_hash ? '%' : '@', $gv);
3897 return $quoted ? "$name->"
3899 ? '${#}' # avoid ${#}[1] => $#[1]
3909 if ($op->private & OPpMULTIDEREF_EXISTS) {
3910 $text = $self->keyword("exists"). " ";
3912 elsif ($op->private & OPpMULTIDEREF_DELETE) {
3913 $text = $self->keyword("delete"). " ";
3915 elsif ($op->private & OPpLVAL_INTRO) {
3916 $text = $self->keyword("local"). " ";
3919 if ($op->first && ($op->first->flags & OPf_KIDS)) {
3920 # arbitrary initial expression, e.g. f(1,2,3)->[...]
3921 $text .= $self->deparse($op->first, 24);
3924 my @items = $op->aux_list($self->{curcv});
3925 my $actions = shift @items;
3931 if (($actions & MDEREF_ACTION_MASK) == MDEREF_reload) {
3932 $actions = shift @items;
3937 ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_pop_rv2hv_helem
3938 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvsv_vivify_rv2hv_helem
3939 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padsv_vivify_rv2hv_helem
3940 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_vivify_rv2hv_helem
3941 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem
3942 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem
3945 if ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_padav_aelem
3946 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem)
3949 $text .= '$' . substr($self->padname(shift @items), 1);
3951 elsif ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_gvav_aelem
3952 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem)
3955 $text .= $self->multideref_var_name(shift @items, $is_hash);
3958 if ( ($actions & MDEREF_ACTION_MASK) ==
3959 MDEREF_AV_padsv_vivify_rv2av_aelem
3960 || ($actions & MDEREF_ACTION_MASK) ==
3961 MDEREF_HV_padsv_vivify_rv2hv_helem)
3963 $text .= $self->padname(shift @items);
3965 elsif ( ($actions & MDEREF_ACTION_MASK) ==
3966 MDEREF_AV_gvsv_vivify_rv2av_aelem
3967 || ($actions & MDEREF_ACTION_MASK) ==
3968 MDEREF_HV_gvsv_vivify_rv2hv_helem)
3970 $text .= $self->multideref_var_name(shift @items, $is_hash);
3972 elsif ( ($actions & MDEREF_ACTION_MASK) ==
3973 MDEREF_AV_pop_rv2av_aelem
3974 || ($actions & MDEREF_ACTION_MASK) ==
3975 MDEREF_HV_pop_rv2hv_helem)
3977 if ( ($op->flags & OPf_KIDS)
3978 && ( _op_is_or_was($op->first, OP_RV2AV)
3979 || _op_is_or_was($op->first, OP_RV2HV))
3980 && ($op->first->flags & OPf_KIDS)
3981 && ( _op_is_or_was($op->first->first, OP_AELEM)
3982 || _op_is_or_was($op->first->first, OP_HELEM))
3989 $text .= '->' if !$derefs++;
3993 if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_none) {
3997 $text .= $is_hash ? '{' : '[';
3999 if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_const) {
4000 my $key = shift @items;
4002 $text .= $self->const($key, $cx);
4008 elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_padsv) {
4009 $text .= $self->padname(shift @items);
4011 elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_gvsv) {
4012 $text .= '$' . ($self->stash_variable_name('$', shift @items))[0];
4015 $text .= $is_hash ? '}' : ']';
4017 if ($actions & MDEREF_FLAG_last) {
4020 $actions >>= MDEREF_SHIFT;
4027 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
4028 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
4033 my($glob, $part) = ($op->first, $op->last);
4034 $glob = $glob->first; # skip rv2gv
4035 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
4036 my $scope = is_scope($glob);
4037 $glob = $self->deparse($glob, 0);
4038 $part = $self->deparse($part, 1);
4039 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
4044 my ($op, $cx, $left, $right, $regname, $padname) = @_;
4046 my(@elems, $kid, $array, $list);
4047 if (class($op) eq "LISTOP") {
4049 } else { # ex-hslice inside delete()
4050 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
4054 $array = $array->first
4055 if $array->name eq $regname or $array->name eq "null";
4056 $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
4057 $kid = $op->first->sibling; # skip pushmark
4058 if ($kid->name eq "list") {
4059 $kid = $kid->first->sibling; # skip list, pushmark
4060 for (; !null $kid; $kid = $kid->sibling) {
4061 push @elems, $self->deparse($kid, 6);
4063 $list = join(", ", @elems);
4065 $list = $self->elem_or_slice_single_index($kid);
4068 $lead = '%' if $op->name =~ /^kv/i;
4069 return $lead . $array . $left . $list . $right;
4072 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
4073 sub pp_kvaslice { slice(@_, "[", "]", "rv2av", "padav") }
4074 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
4075 sub pp_kvhslice { slice(@_, "{", "}", "rv2hv", "padhv") }
4080 my $idx = $op->first;
4081 my $list = $op->last;
4083 $list = $self->deparse($list, 1);
4084 $idx = $self->deparse($idx, 1);
4085 return "($list)" . "[$idx]";
4090 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
4095 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
4101 my $kid = $op->first->sibling; # skip pushmark
4102 my($meth, $obj, @exprs);
4103 if ($kid->name eq "list" and want_list $kid) {
4104 # When an indirect object isn't a bareword but the args are in
4105 # parens, the parens aren't part of the method syntax (the LLAFR
4106 # doesn't apply), but they make a list with OPf_PARENS set that
4107 # doesn't get flattened by the append_elem that adds the method,
4108 # making a (object, arg1, arg2, ...) list where the object
4109 # usually is. This can be distinguished from
4110 # '($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
4111 # object) because in the later the list is in scalar context
4112 # as the left side of -> always is, while in the former
4113 # the list is in list context as method arguments always are.
4114 # (Good thing there aren't method prototypes!)
4115 $meth = $kid->sibling;
4116 $kid = $kid->first->sibling; # skip pushmark
4118 $kid = $kid->sibling;
4119 for (; not null $kid; $kid = $kid->sibling) {
4124 $kid = $kid->sibling;
4125 for (; !null ($kid->sibling) && $kid->name!~/^method(?:_named)?\z/;
4126 $kid = $kid->sibling) {
4132 if ($meth->name eq "method_named") {
4133 $meth = $self->meth_sv($meth)->PV;
4134 } elsif ($meth->name eq "method_super") {
4135 $meth = "SUPER::".$self->meth_sv($meth)->PV;
4136 } elsif ($meth->name eq "method_redir") {
4137 $meth = $self->meth_rclass_sv($meth)->PV.'::'.$self->meth_sv($meth)->PV;
4138 } elsif ($meth->name eq "method_redir_super") {
4139 $meth = $self->meth_rclass_sv($meth)->PV.'::SUPER::'.
4140 $self->meth_sv($meth)->PV;
4142 $meth = $meth->first;
4143 if ($meth->name eq "const") {
4144 # As of 5.005_58, this case is probably obsoleted by the
4145 # method_named case above
4146 $meth = $self->const_sv($meth)->PV; # needs to be bare
4150 return { method => $meth, variable_method => ref($meth),
4151 object => $obj, args => \@exprs },
4155 # compat function only
4158 my $info = $self->_method(@_);
4159 return $self->e_method( $self->_method(@_) );
4163 my ($self, $info, $cx) = @_;
4164 my $obj = $self->deparse($info->{object}, 24);
4166 my $meth = $info->{method};
4167 $meth = $self->deparse($meth, 1) if $info->{variable_method};
4168 my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
4169 if ($info->{object}->name eq 'scope' && want_list $info->{object}) {
4170 # method { $object }
4171 # This must be deparsed this way to preserve list context
4173 my $need_paren = $cx >= 6;
4174 return '(' x $need_paren
4175 . $meth . substr($obj,2) # chop off the "do"
4177 . ')' x $need_paren;
4179 my $kid = $obj . "->" . $meth;
4181 return $kid . "(" . $args . ")"; # parens mandatory
4187 # returns "&" if the prototype doesn't match the args,
4188 # or ("", $args_after_prototype_demunging) if it does.
4191 return "&" if $self->{'noproto'};
4192 my($proto, @args) = @_;
4196 # An unbackslashed @ or % gobbles up the rest of the args
4197 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
4200 $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)\s*//;
4203 return "&" if @args;
4204 } elsif ($chr eq ";") {
4206 } elsif ($chr eq "@" or $chr eq "%") {
4207 push @reals, map($self->deparse($_, 6), @args);
4212 if ($chr eq "\$" || $chr eq "_") {
4213 if (want_scalar $arg) {
4214 push @reals, $self->deparse($arg, 6);
4218 } elsif ($chr eq "&") {
4219 if ($arg->name =~ /^(s?refgen|undef)$/) {
4220 push @reals, $self->deparse($arg, 6);
4224 } elsif ($chr eq "*") {
4225 if ($arg->name =~ /^s?refgen$/
4226 and $arg->first->first->name eq "rv2gv")
4228 $real = $arg->first->first; # skip refgen, null
4229 if ($real->first->name eq "gv") {
4230 push @reals, $self->deparse($real, 6);
4232 push @reals, $self->deparse($real->first, 6);
4237 } elsif (substr($chr, 0, 1) eq "\\") {
4239 if ($arg->name =~ /^s?refgen$/ and
4240 !null($real = $arg->first) and
4241 ($chr =~ /\$/ && is_scalar($real->first)
4243 && class($real->first->sibling) ne 'NULL'
4244 && $real->first->sibling->name
4247 && class($real->first->sibling) ne 'NULL'
4248 && $real->first->sibling->name
4250 #or ($chr =~ /&/ # This doesn't work
4251 # && $real->first->name eq "rv2cv")
4253 && $real->first->name eq "rv2gv")))
4255 push @reals, $self->deparse($real, 6);
4262 return "&" if $proto and !$doneok; # too few args and no ';'
4263 return "&" if @args; # too many args
4264 return ("", join ", ", @reals);
4268 my $name = $_[0]->name;
4269 # XXX There has to be a better way of doing this scalar-op check.
4270 # Currently PL_opargs is not exposed.
4271 if ($name eq 'null') {
4272 $name = substr B::ppname($_[0]->targ), 3
4274 $name =~ /^(?:scalar|pushmark|wantarray|const|gvsv|gv|padsv|rv2gv
4275 |rv2sv|av2arylen|anoncode|prototype|srefgen|ref|bless
4276 |regcmaybe|regcreset|regcomp|qr|subst|substcont|trans
4277 |transr|sassign|chop|schop|chomp|schomp|defined|undef
4278 |study|pos|preinc|i_preinc|predec|i_predec|postinc
4279 |i_postinc|postdec|i_postdec|pow|multiply|i_multiply
4280 |divide|i_divide|modulo|i_modulo|add|i_add|subtract
4281 |i_subtract|concat|stringify|left_shift|right_shift|lt
4282 |i_lt|gt|i_gt|le|i_le|ge|i_ge|eq|i_eq|ne|i_ne|ncmp|i_ncmp
4283 |slt|sgt|sle|sge|seq|sne|scmp|bit_and|bit_xor|bit_or
4284 |negate|i_negate|not|complement|smartmatch|atan2|sin|cos
4285 |rand|srand|exp|log|sqrt|int|hex|oct|abs|length|substr
4286 |vec|index|rindex|sprintf|formline|ord|chr|crypt|ucfirst
4287 |lcfirst|uc|lc|quotemeta|aelemfast|aelem|exists|helem
4288 |pack|join|anonlist|anonhash|push|pop|shift|unshift|xor
4289 |andassign|orassign|dorassign|warn|die|reset|nextstate
4290 |dbstate|unstack|last|next|redo|dump|goto|exit|open|close
4291 |pipe_op|fileno|umask|binmode|tie|untie|tied|dbmopen
4292 |dbmclose|select|getc|read|enterwrite|prtf|print|say
4293 |sysopen|sysseek|sysread|syswrite|eof|tell|seek|truncate
4294 |fcntl|ioctl|flock|send|recv|socket|sockpair|bind|connect
4295 |listen|accept|shutdown|gsockopt|ssockopt|getsockname
4296 |getpeername|ftrread|ftrwrite|ftrexec|fteread|ftewrite
4297 |fteexec|ftis|ftsize|ftmtime|ftatime|ftctime|ftrowned
4298 |fteowned|ftzero|ftsock|ftchr|ftblk|ftfile|ftdir|ftpipe
4299 |ftsuid|ftsgid|ftsvtx|ftlink|fttty|fttext|ftbinary|chdir
4300 |chown|chroot|unlink|chmod|utime|rename|link|symlink
4301 |readlink|mkdir|rmdir|open_dir|telldir|seekdir|rewinddir
4302 |closedir|fork|wait|waitpid|system|exec|kill|getppid
4303 |getpgrp|setpgrp|getpriority|setpriority|time|alarm|sleep
4304 |shmget|shmctl|shmread|shmwrite|msgget|msgctl|msgsnd
4305 |msgrcv|semop|semget|semctl|hintseval|shostent|snetent
4306 |sprotoent|sservent|ehostent|enetent|eprotoent|eservent
4307 |spwent|epwent|sgrent|egrent|getlogin|syscall|lock|runcv
4314 return $self->e_method($self->_method($op, $cx))
4315 unless null $op->first->sibling;
4319 if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
4321 } elsif ($op->private & OPpENTERSUB_AMPER) {
4325 $kid = $kid->first->sibling; # skip ex-list, pushmark
4326 for (; not null $kid->sibling; $kid = $kid->sibling) {
4331 if (is_scope($kid)) {
4333 $kid = "{" . $self->deparse($kid, 0) . "}";
4334 } elsif ($kid->first->name eq "gv") {
4335 my $gv = $self->gv_or_padgv($kid->first);
4337 if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL"
4338 || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') {
4339 $proto = $cv->PV if $cv->FLAGS & SVf_POK;
4341 $simple = 1; # only calls of named functions can be prototyped
4342 $kid = $self->deparse($kid, 24);
4344 # Fully qualify any sub name that conflicts with a lexical.
4345 if ($self->lex_in_scope("&$kid")
4346 || $self->lex_in_scope("&$kid", 1))
4350 if ($kid eq 'main::') {
4354 if ($kid !~ /::/ && $kid ne 'x') {
4355 # Fully qualify any sub name that is also a keyword. While
4356 # we could check the import flag, we cannot guarantee that
4357 # the code deparsed so far would set that flag, so we qual-
4358 # ify the names regardless of importation.
4359 if (exists $feature_keywords{$kid}) {
4360 $fq++ if $self->feature_enabled($kid);
4361 } elsif (do { local $@; local $SIG{__DIE__};
4362 eval { () = prototype "CORE::$kid"; 1 } }) {
4366 if ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
4367 $kid = single_delim("q", "'", $kid, $self) . '->';
4371 $fq and substr $kid, 0, 0, = $self->{'curstash'}.'::';
4372 } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
4374 $kid = $self->deparse($kid, 24);
4377 my $arrow = is_subscriptable($kid->first) || $kid->first->name eq "padcv" ? "" : "->";
4378 $kid = $self->deparse($kid, 24) . $arrow;
4381 # Doesn't matter how many prototypes there are, if
4382 # they haven't happened yet!
4383 my $declared = exists $self->{'subs_declared'}{$kid};
4384 if (!$declared && defined($proto)) {
4385 # Avoid "too early to check prototype" warning
4386 ($amper, $proto) = ('&');
4391 if ($declared and defined $proto and not $amper) {
4392 ($amper, $args) = $self->check_proto($proto, @exprs);
4396 $args = join(", ", map(
4397 ($_->flags & OPf_WANT) == OPf_WANT_SCALAR
4399 ? $self->maybe_parens_unop('scalar', $_, 6)
4400 : $self->deparse($_, 6),
4404 if ($prefix or $amper) {
4405 if ($kid eq '&') { $kid = "{$kid}" } # &{&} cannot be written as &&
4406 if ($op->flags & OPf_STACKED) {
4407 return $prefix . $amper . $kid . "(" . $args . ")";
4409 return $prefix . $amper. $kid;
4412 # It's a syntax error to call CORE::GLOBAL::foo with a prefix,
4413 # so it must have been translated from a keyword call. Translate
4415 $kid =~ s/^CORE::GLOBAL:://;
4417 my $dproto = defined($proto) ? $proto : "undefined";
4419 return "$kid(" . $args . ")";
4420 } elsif ($dproto =~ /^\s*\z/) {
4422 } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
4423 # is_scalar is an excessively conservative test here:
4424 # really, we should be comparing to the precedence of the
4425 # top operator of $exprs[0] (ala unop()), but that would
4426 # take some major code restructuring to do right.
4427 return $self->maybe_parens_func($kid, $args, $cx, 16);
4428 } elsif ($dproto ne '$' and defined($proto) || $simple) { #'
4429 return $self->maybe_parens_func($kid, $args, $cx, 5);
4431 return "$kid(" . $args . ")";
4436 sub pp_enterwrite { unop(@_, "write") }
4438 # escape things that cause interpolation in double quotes,
4439 # but not character escapes
4442 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
4450 # Matches any string which is balanced with respect to {braces}
4461 # the same, but treat $|, $), $( and $ at the end of the string differently
4462 # and leave comments unmangled for the sake of /x and (?x).
4476 ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
4477 | \#[^\n]* # (skip over comments)
4484 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
4490 my %unctrl = # portable to EBCDIC
4492 "\c@" => '\c@', # unused
4519 "\c[" => '\c[', # unused
4520 "\c\\" => '\c\\', # unused
4521 "\c]" => '\c]', # unused
4522 "\c_" => '\c_', # unused
4525 # character escapes, but not delimiters that might need to be escaped
4526 sub escape_str { # ASCII, UTF8
4528 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
4530 # $str =~ s/\cH/\\b/g; # \b means something different in a regex
4536 $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
4537 $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/age;
4541 # For regexes. Leave whitespace unmangled in case of /x or (?x).
4544 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
4545 $str =~ s/([[:^print:]])/
4546 ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/age;
4547 $str =~ s/\n/\n\f/g;
4551 # Don't do this for regexen
4554 $str =~ s/\\/\\\\/g;
4558 # Remove backslashes which precede literal control characters,
4559 # to avoid creating ambiguity when we escape the latter.
4563 # the insane complexity here is due to the behaviour of "\c\"
4564 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
4568 sub balanced_delim {
4570 my @str = split //, $str;
4571 my($ar, $open, $close, $fail, $c, $cnt, $last_bs);
4572 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
4573 ($open, $close) = @$ar;
4574 $fail = 0; $cnt = 0; $last_bs = 0;
4577 $fail = 1 if $last_bs;
4579 } elsif ($c eq $close) {
4580 $fail = 1 if $last_bs;
4588 $last_bs = $c eq '\\';
4590 $fail = 1 if $cnt != 0;
4591 return ($open, "$open$str$close") if not $fail;
4597 my($q, $default, $str, $self) = @_;
4598 return "$default$str$default" if $default and index($str, $default) == -1;
4599 my $coreq = $self->keyword($q); # maybe CORE::q
4601 (my $succeed, $str) = balanced_delim($str);
4602 return "$coreq$str" if $succeed;
4604 for my $delim ('/', '"', '#') {
4605 return "$coreq$delim" . $str . $delim if index($str, $delim) == -1;
4608 $str =~ s/$default/\\$default/g;
4609 return "$default$str$default";
4612 return "$coreq/$str/";
4617 BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
4619 # Split a floating point number into an integer mantissa and a binary
4620 # exponent. Assumes you've already made sure the number isn't zero or
4621 # some weird infinity or NaN.
4625 if ($f == int($f)) {
4626 while ($f % 2 == 0) {
4631 while ($f != int($f)) {
4636 my $mantissa = sprintf("%.0f", $f);
4637 return ($mantissa, $exponent);
4643 if ($self->{'use_dumper'}) {
4644 return $self->const_dumper($sv, $cx);
4646 if (class($sv) eq "SPECIAL") {
4647 # sv_undef, sv_yes, sv_no
4648 return $$sv == 3 ? $self->maybe_parens("!1", $cx, 21)
4649 : ('undef', '1')[$$sv-1];
4651 if (class($sv) eq "NULL") {
4654 # convert a version object into the "v1.2.3" string in its V magic
4655 if ($sv->FLAGS & SVs_RMG) {
4656 for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
4657 return $mg->PTR if $mg->TYPE eq 'V';
4661 if ($sv->FLAGS & SVf_IOK) {
4662 my $str = $sv->int_value;
4663 $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
4665 } elsif ($sv->FLAGS & SVf_NOK) {
4668 if (pack("F", $nv) eq pack("F", 0)) {
4673 return $self->maybe_parens("-.0", $cx, 21);
4675 } elsif (1/$nv == 0) {
4678 return $self->maybe_parens("9**9**9", $cx, 22);
4681 return $self->maybe_parens("-9**9**9", $cx, 21);
4683 } elsif ($nv != $nv) {
4685 if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
4687 return "sin(9**9**9)";
4688 } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
4690 return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
4693 my $hex = unpack("h*", pack("F", $nv));
4694 return qq'unpack("F", pack("h*", "$hex"))';
4697 # first, try the default stringification
4700 # failing that, try using more precision
4701 $str = sprintf("%.${max_prec}g", $nv);
4702 # if (pack("F", $str) ne pack("F", $nv)) {
4704 # not representable in decimal with whatever sprintf()
4705 # and atof() Perl is using here.
4706 my($mant, $exp) = split_float($nv);
4707 return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
4710 $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
4712 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
4714 if (class($ref) eq "AV") {
4715 return "[" . $self->list_const(2, $ref->ARRAY) . "]";
4716 } elsif (class($ref) eq "HV") {
4717 my %hash = $ref->ARRAY;
4719 for my $k (sort keys %hash) {
4720 push @elts, "$k => " . $self->const($hash{$k}, 6);
4722 return "{" . join(", ", @elts) . "}";
4723 } elsif (class($ref) eq "CV") {
4725 if ($] > 5.0150051) {
4726 require overloading;
4727 unimport overloading;
4730 if ($] > 5.0150051 && $self->{curcv} &&
4731 $self->{curcv}->object_2svref == $ref->object_2svref) {
4732 return $self->keyword("__SUB__");
4734 return "sub " . $self->deparse_sub($ref);
4736 if ($ref->FLAGS & SVs_SMG) {
4737 for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
4738 if ($mg->TYPE eq 'r') {
4739 my $re = re_uninterp(escape_re(re_unback($mg->precomp)));
4740 return single_delim("qr", "", $re, $self);
4745 my $const = $self->const($ref, 20);
4746 if ($self->{in_subst_repl} && $const =~ /^[0-9]/) {
4747 $const = "($const)";
4749 return $self->maybe_parens("\\$const", $cx, 20);
4750 } elsif ($sv->FLAGS & SVf_POK) {
4752 if ($str =~ /[[:^print:]]/a) {
4753 return single_delim("qq", '"',
4754 uninterp(escape_str unback $str), $self);
4756 return single_delim("q", "'", unback($str), $self);
4766 my $ref = $sv->object_2svref();
4767 my $dumper = Data::Dumper->new([$$ref], ['$v']);
4768 $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
4769 my $str = $dumper->Dump();
4770 if ($str =~ /^\$v/) {
4771 return '${my ' . $str . ' \$v}';
4781 # the constant could be in the pad (under useithreads)
4782 $sv = $self->padval($op->targ) unless $$sv;
4789 my $sv = $op->meth_sv;
4790 # the constant could be in the pad (under useithreads)
4791 $sv = $self->padval($op->targ) unless $$sv;
4795 sub meth_rclass_sv {
4798 my $sv = $op->rclass;
4799 # the constant could be in the pad (under useithreads)
4800 $sv = $self->padval($sv) unless ref $sv;
4807 if ($op->private & OPpCONST_ARYBASE) {
4810 # if ($op->private & OPpCONST_BARE) { # trouble with '=>' autoquoting
4811 # return $self->const_sv($op)->PV;
4813 my $sv = $self->const_sv($op);
4814 return $self->const($sv, $cx);
4820 my $type = $op->name;
4821 if ($type eq "const") {
4822 return '$[' if $op->private & OPpCONST_ARYBASE;
4823 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
4824 } elsif ($type eq "concat") {
4825 my $first = $self->dq($op->first);
4826 my $last = $self->dq($op->last);
4828 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
4829 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
4830 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
4831 || ($last =~ /^[:'{\[\w_]/ && #'
4832 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
4834 return $first . $last;
4835 } elsif ($type eq "uc") {
4836 return '\U' . $self->dq($op->first->sibling) . '\E';
4837 } elsif ($type eq "lc") {
4838 return '\L' . $self->dq($op->first->sibling) . '\E';
4839 } elsif ($type eq "ucfirst") {
4840 return '\u' . $self->dq($op->first->sibling);
4841 } elsif ($type eq "lcfirst") {
4842 return '\l' . $self->dq($op->first->sibling);
4843 } elsif ($type eq "quotemeta") {
4844 return '\Q' . $self->dq($op->first->sibling) . '\E';
4845 } elsif ($type eq "fc") {
4846 return '\F' . $self->dq($op->first->sibling) . '\E';
4847 } elsif ($type eq "join") {
4848 return $self->deparse($op->last, 26); # was join($", @ary)
4850 return $self->deparse($op, 26);
4857 # skip pushmark if it exists (readpipe() vs ``)
4858 my $child = $op->first->sibling->isa('B::NULL')
4859 ? $op->first : $op->first->sibling;
4860 if ($self->pure_string($child)) {
4861 return single_delim("qx", '`', $self->dq($child, 1), $self);
4863 unop($self, @_, "readpipe");
4869 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
4870 return $self->deparse($kid, $cx) if $self->{'unquote'};
4871 $self->maybe_targmy($kid, $cx,
4872 sub {single_delim("qq", '"', $self->dq($_[1]),
4876 # OP_STRINGIFY is a listop, but it only ever has one arg
4878 my ($self, $op, $cx) = @_;
4879 my $kid = $op->first->sibling;
4880 while ($kid->name eq 'null' && !null($kid->first)) {
4883 if ($kid->name =~ /^(?:const|padsv|rv2sv|av2arylen|gvsv|multideref
4884 |aelemfast(?:_lex)?|[ah]elem|join|concat)\z/x) {
4885 maybe_targmy(@_, \&dquote);
4888 # Actually an optimised join.
4889 my $result = listop(@_,"join");
4890 $result =~ s/join([( ])/join$1$self->{'ex_const'}, /;
4895 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
4896 # note that tr(from)/to/ is OK, but not tr/from/(to)
4898 my($from, $to) = @_;
4899 my($succeed, $delim);
4900 if ($from !~ m[/] and $to !~ m[/]) {
4901 return "/$from/$to/";
4902 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
4903 if (($succeed, $to) = balanced_delim($to) and $succeed) {
4906 for $delim ('/', '"', '#') { # note no "'" -- s''' is special
4907 return "$from$delim$to$delim" if index($to, $delim) == -1;
4910 return "$from/$to/";
4913 for $delim ('/', '"', '#') { # note no '
4914 return "$delim$from$delim$to$delim"
4915 if index($to . $from, $delim) == -1;
4917 $from =~ s[/][\\/]g;
4919 return "/$from/$to/";
4923 # Only used by tr///, so backslashes hyphens
4926 if ($n == ord '\\') {
4928 } elsif ($n == ord "-") {
4930 } elsif ($n >= ord(' ') and $n <= ord('~')) {
4932 } elsif ($n == ord "\a") {
4934 } elsif ($n == ord "\b") {
4936 } elsif ($n == ord "\t") {
4938 } elsif ($n == ord "\n") {
4940 } elsif ($n == ord "\e") {
4942 } elsif ($n == ord "\f") {
4944 } elsif ($n == ord "\r") {
4946 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
4947 return '\\c' . chr(ord("@") + $n);
4949 # return '\x' . sprintf("%02x", $n);
4950 return '\\' . sprintf("%03o", $n);
4956 my($str, $c, $tr) = ("");
4957 for ($c = 0; $c < @chars; $c++) {
4960 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
4961 $chars[$c + 2] == $tr + 2)
4963 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
4966 $str .= pchr($chars[$c]);
4972 sub tr_decode_byte {
4973 my($table, $flags) = @_;
4974 my(@table) = unpack("s*", $table);
4975 splice @table, 0x100, 1; # Number of subsequent elements
4976 my($c, $tr, @from, @to, @delfrom, $delhyphen);
4977 if ($table[ord "-"] != -1 and
4978 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
4980 $tr = $table[ord "-"];
4981 $table[ord "-"] = -1;
4985 } else { # -2 ==> delete
4989 for ($c = 0; $c < @table; $c++) {
4992 push @from, $c; push @to, $tr;
4993 } elsif ($tr == -2) {
4997 @from = (@from, @delfrom);
4998 if ($flags & OPpTRANS_COMPLEMENT) {
5001 @from{@from} = (1) x @from;
5002 for ($c = 0; $c < 256; $c++) {
5003 push @newfrom, $c unless $from{$c};
5007 unless ($flags & OPpTRANS_DELETE || !@to) {
5008 pop @to while $#to and $to[$#to] == $to[$#to -1];
5011 $from = collapse(@from);
5012 $to = collapse(@to);
5013 $from .= "-" if $delhyphen;
5014 return ($from, $to);
5019 if ($x == ord "-") {
5021 } elsif ($x == ord "\\") {
5028 # XXX This doesn't yet handle all cases correctly either
5030 sub tr_decode_utf8 {
5031 my($swash_hv, $flags) = @_;
5032 my %swash = $swash_hv->ARRAY;
5034 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
5035 my $none = $swash{"NONE"}->IV;
5036 my $extra = $none + 1;
5037 my(@from, @delfrom, @to);
5039 foreach $line (split /\n/, $swash{'LIST'}->PV) {
5040 my($min, $max, $result) = split(/\t/, $line);
5047 $result = hex $result;
5048 if ($result == $extra) {
5049 push @delfrom, [$min, $max];
5051 push @from, [$min, $max];
5052 push @to, [$result, $result + $max - $min];
5055 for my $i (0 .. $#from) {
5056 if ($from[$i][0] == ord '-') {
5057 unshift @from, splice(@from, $i, 1);
5058 unshift @to, splice(@to, $i, 1);
5060 } elsif ($from[$i][1] == ord '-') {
5063 unshift @from, ord '-';
5064 unshift @to, ord '-';
5068 for my $i (0 .. $#delfrom) {
5069 if ($delfrom[$i][0] == ord '-') {
5070 push @delfrom, splice(@delfrom, $i, 1);
5072 } elsif ($delfrom[$i][1] == ord '-') {
5074 push @delfrom, ord '-';
5078 if (defined $final and $to[$#to][1] != $final) {
5079 push @to, [$final, $final];
5081 push @from, @delfrom;
5082 if ($flags & OPpTRANS_COMPLEMENT) {
5085 for my $i (0 .. $#from) {
5086 push @newfrom, [$next, $from[$i][0] - 1];
5087 $next = $from[$i][1] + 1;
5090 for my $range (@newfrom) {
5091 if ($range->[0] <= $range->[1]) {
5096 my($from, $to, $diff);
5097 for my $chunk (@from) {
5098 $diff = $chunk->[1] - $chunk->[0];
5100 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
5101 } elsif ($diff == 1) {
5102 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
5104 $from .= tr_chr($chunk->[0]);
5107 for my $chunk (@to) {
5108 $diff = $chunk->[1] - $chunk->[0];
5110 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
5111 } elsif ($diff == 1) {
5112 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
5114 $to .= tr_chr($chunk->[0]);
5117 #$final = sprintf("%04x", $final) if defined $final;
5118 #$none = sprintf("%04x", $none) if defined $none;
5119 #$extra = sprintf("%04x", $extra) if defined $extra;
5120 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
5121 #print STDERR $swash{'LIST'}->PV;
5122 return (escape_str($from), escape_str($to));
5127 my($op, $cx, $morflags) = @_;
5129 my $class = class($op);
5130 my $priv_flags = $op->private;
5131 if ($class eq "PVOP") {
5132 ($from, $to) = tr_decode_byte($op->pv, $priv_flags);
5133 } elsif ($class eq "PADOP") {
5135 = tr_decode_utf8($self->padval($op->padix)->RV, $priv_flags);
5136 } else { # class($op) eq "SVOP"
5137 ($from, $to) = tr_decode_utf8($op->sv->RV, $priv_flags);
5140 $flags .= "c" if $priv_flags & OPpTRANS_COMPLEMENT;
5141 $flags .= "d" if $priv_flags & OPpTRANS_DELETE;
5142 $to = "" if $from eq $to and $flags eq "";
5143 $flags .= "s" if $priv_flags & OPpTRANS_SQUASH;
5144 $flags .= $morflags if defined $morflags;
5145 my $ret = $self->keyword("tr") . double_delim($from, $to) . $flags;
5146 if (my $targ = $op->targ) {
5147 return $self->maybe_parens($self->padname($targ) . " =~ $ret",
5153 sub pp_transr { push @_, 'r'; goto &pp_trans }
5155 sub re_dq_disambiguate {
5156 my ($first, $last) = @_;
5157 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
5158 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
5159 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
5160 || ($last =~ /^[{\[\w_]/ &&
5161 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
5162 return $first . $last;
5165 # Like dq(), but different
5170 my $type = $op->name;
5171 if ($type eq "const") {
5172 return '$[' if $op->private & OPpCONST_ARYBASE;
5173 my $unbacked = re_unback($self->const_sv($op)->as_string);
5174 return re_uninterp(escape_re($unbacked));
5175 } elsif ($type eq "concat") {
5176 my $first = $self->re_dq($op->first);
5177 my $last = $self->re_dq($op->last);
5178 return re_dq_disambiguate($first, $last);
5179 } elsif ($type eq "uc") {
5180 return '\U' . $self->re_dq($op->first->sibling) . '\E';
5181 } elsif ($type eq "lc") {
5182 return '\L' . $self->re_dq($op->first->sibling) . '\E';
5183 } elsif ($type eq "ucfirst") {
5184 return '\u' . $self->re_dq($op->first->sibling);
5185 } elsif ($type eq "lcfirst") {
5186 return '\l' . $self->re_dq($op->first->sibling);
5187 } elsif ($type eq "quotemeta") {
5188 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
5189 } elsif ($type eq "fc") {
5190 return '\F' . $self->re_dq($op->first->sibling) . '\E';
5191 } elsif ($type eq "join") {
5192 return $self->deparse($op->last, 26); # was join($", @ary)
5194 my $ret = $self->deparse($op, 26);
5195 $ret =~ s/^\$([(|)])\z/\${$1}/ # $( $| $) need braces
5196 or $ret =~ s/^\@([-+])\z/\@{$1}/; # @- @+ need braces
5202 my ($self, $op) = @_;
5203 return 0 if null $op;
5204 my $type = $op->name;
5206 if ($type eq 'const' || $type eq 'av2arylen') {
5209 elsif ($type =~ /^(?:[ul]c(first)?|fc)$/ || $type eq 'quotemeta') {
5210 return $self->pure_string($op->first->sibling);
5212 elsif ($type eq 'join') {
5213 my $join_op = $op->first->sibling; # Skip pushmark
5214 return 0 unless $join_op->name eq 'null' && $join_op->targ == OP_RV2SV;
5216 my $gvop = $join_op->first;
5217 return 0 unless $gvop->name eq 'gvsv';
5218 return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
5220 return 0 unless ${$join_op->sibling} eq ${$op->last};
5221 return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
5223 elsif ($type eq 'concat') {
5224 return $self->pure_string($op->first)
5225 && $self->pure_string($op->last);
5227 elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
5230 elsif ($type eq "null" and $op->can('first') and not null $op->first) {
5231 my $first = $op->first;
5233 return 1 if $first->name eq "multideref";
5234 return 1 if $first->name eq "aelemfast_lex";
5236 if ( $first->name eq "null"
5237 and $first->can('first')
5238 and not null $first->first
5239 and $first->first->name eq "aelemfast"
5250 my ($self,$op,$cv) = @_;
5252 # localise stuff relating to the current sub
5254 local($self->{'curcv'}) = $cv,
5255 local($self->{'curcvlex'}),
5256 local(@$self{qw'curstash warnings hints hinthash curcop'})
5257 = @$self{qw'curstash warnings hints hinthash curcop'};
5260 for ($op = $op->first->sibling; !null($op); $op = $op->sibling) {
5261 if ($op->name eq 'null' and $op->flags & OPf_SPECIAL) {
5262 my $scope = $op->first;
5263 # 0 context (last arg to scopeop) means statement context, so
5264 # the contents of the block will not be wrapped in do{...}.
5265 my $block = scopeop($scope->first->name eq "enter", $self,
5267 # next op is the source code of the block
5269 $re .= ($self->const_sv($op)->PV =~ m|^(\(\?\??\{)|)[0];
5270 my $multiline = $block =~ /\n/;
5271 $re .= $multiline ? "\n\t" : ' ';
5273 $re .= $multiline ? "\n\b})" : " })";
5275 $re = re_dq_disambiguate($re, $self->re_dq($op));
5284 my $kid = $op->first;
5285 $kid = $kid->first if $kid->name eq "regcmaybe";
5286 $kid = $kid->first if $kid->name eq "regcreset";
5287 my $kname = $kid->name;
5288 if ($kname eq "null" and !null($kid->first)
5289 and $kid->first->name eq 'pushmark')
5292 $kid = $kid->first->sibling;
5293 while (!null($kid)) {
5295 my $last = $self->re_dq($kid);
5296 $str = re_dq_disambiguate($first, $last);
5297 $kid = $kid->sibling;
5302 return ($self->re_dq($kid), 1)
5303 if $kname =~ /^(?:rv2|pad)av/ or $self->pure_string($kid);
5304 return ($self->deparse($kid, $cx), 0);
5308 my ($self, $op, $cx) = @_;
5309 return (($self->regcomp($op, $cx, 0))[0]);
5313 my ($self, $op) = @_;
5315 my $pmflags = $op->pmflags;
5317 my $re = $op->pmregexp;
5319 $pmflags = $re->compflags;
5322 $flags .= "g" if $pmflags & PMf_GLOBAL;
5323 $flags .= "i" if $pmflags & PMf_FOLD;
5324 $flags .= "m" if $pmflags & PMf_MULTILINE;
5325 $flags .= "o" if $pmflags & PMf_KEEP;
5326 $flags .= "s" if $pmflags & PMf_SINGLELINE;
5327 $flags .= "x" if $pmflags & PMf_EXTENDED;
5328 $flags .= "x" if $pmflags & PMf_EXTENDED_MORE;
5329 $flags .= "p" if $pmflags & RXf_PMf_KEEPCOPY;
5330 if (my $charset = $pmflags & RXf_PMf_CHARSET) {
5331 # Hardcoding this is fragile, but B does not yet export the
5332 # constants we need.
5333 $flags .= qw(d l u a aa)[$charset >> 6]
5335 # The /d flag is indicated by 0; only show it if necessary.
5336 elsif ($self->{hinthash} and
5337 $self->{hinthash}{reflags_charset}
5338 || $self->{hinthash}{feature_unicode}
5339 or $self->{hints} & $feature::hint_mask
5340 && ($self->{hints} & $feature::hint_mask)
5341 != $feature::hint_mask
5343 $self->{hints} & $feature::hint_uni8bit;
5351 # osmic acid -- see osmium tetroxide
5354 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
5355 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
5356 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi', 'soup', 'soupmix');
5358 # When deparsing a regular expression with code blocks, we have to look in
5359 # various places to find the blocks.
5361 # For qr/(?{...})/ without interpolation, the CV is under $qr->qr_anoncv
5362 # and the code list (list of blocks and constants, maybe vars) is under
5363 # $cv->ROOT->first->code_list:
5364 # ./perl -Ilib -MB -e 'use O "Concise", B::svref_2object(sub {qr/(?{die})/})->ROOT->first->first->sibling->pmregexp->qr_anoncv->object_2svref'
5366 # For qr/$a(?{...})/ with interpolation, the code list is more accessible,
5367 # under $pmop->code_list, but the $cv is something you have to dig for in
5368 # the regcomp op’s kids:
5369 # ./perl -Ilib -mO=Concise -e 'qr/$a(?{die})/'
5371 # For m// and split //, things are much simpler. There is no CV. The code
5372 # list is under $pmop->code_list.
5376 my($op, $cx, $name, $delim) = @_;
5377 my $kid = $op->first;
5378 my ($binop, $var, $re) = ("", "", "");
5379 if ($op->flags & OPf_STACKED) {
5381 $var = $self->deparse($kid, 20);
5382 $kid = $kid->sibling;
5384 # not $name; $name will be 'm' for both match and split
5385 elsif ($op->name eq 'match' and my $targ = $op->targ) {
5387 $var = $self->padname($targ);
5390 my $pmflags = $op->pmflags;
5391 my $rhs_bound_to_defsv;
5393 my $have_kid = !null $kid;
5394 # Check for code blocks first
5395 if (not null my $code_list = $op->code_list) {
5396 $re = $self->code_list($code_list,
5399 $kid->first # ex-list
5401 ->sibling # entersub
5410 } elsif (${$bregexp = $op->pmregexp} && ${$cv = $bregexp->qr_anoncv}) {
5411 my $patop = $cv->ROOT # leavesub
5414 $re = $self->code_list($patop, $cv);
5415 } elsif (!$have_kid) {
5416 $re = re_uninterp(escape_re(re_unback($op->precomp)));
5417 } elsif ($kid->name ne 'regcomp') {
5418 carp("found ".$kid->name." where regcomp expected");
5420 ($re, $quote) = $self->regcomp($kid, 21);
5422 if ($have_kid and $kid->name eq 'regcomp') {
5423 my $matchop = $kid->first;
5424 if ($matchop->name eq 'regcreset') {
5425 $matchop = $matchop->first;
5427 if ($matchop->name =~ /^(?:match|transr?|subst)\z/
5428 && $matchop->flags & OPf_SPECIAL) {
5429 $rhs_bound_to_defsv = 1;
5433 $flags .= "c" if $pmflags & PMf_CONTINUE;
5434 $flags .= $self->re_flags($op);
5435 $flags = join '', sort split //, $flags;
5436 $flags = $matchwords{$flags} if $matchwords{$flags};
5437 if ($pmflags & PMf_ONCE) { # only one kind of delimiter works here
5439 $re = $self->keyword("m") . "?$re?"; # explicit 'm' is required
5441 $re = single_delim($name, $delim, $re, $self);
5443 $re = $re . $flags if $quote;
5446 $self->maybe_parens(
5448 ? "$var =~ (\$_ =~ $re)"
5457 sub pp_match { matchop(@_, "m", "/") }
5458 sub pp_pushre { matchop(@_, "m", "/") }
5459 sub pp_qr { matchop(@_, "qr", "") }
5461 sub pp_runcv { unop(@_, "__SUB__"); }
5464 maybe_targmy(@_, \&split);
5469 my($kid, @exprs, $ary, $expr);
5472 # For our kid (an OP_PUSHRE), pmreplroot is never actually the
5473 # root of a replacement; it's either empty, or abused to point to
5474 # the GV for an array we split into (an optimization to save
5475 # assignment overhead). Depending on whether we're using ithreads,
5476 # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
5477 # figures out for us which it is.
5478 my $replroot = $kid->pmreplroot;
5480 my $stacked = $op->flags & OPf_STACKED;
5481 if (ref($replroot) eq "B::GV") {
5483 } elsif (!ref($replroot) and $replroot > 0) {
5484 $gv = $self->padval($replroot);
5485 } elsif ($kid->targ) {
5486 $ary = $self->padname($kid->targ)
5487 } elsif ($stacked) {
5488 $ary = $self->deparse($op->last, 7);
5490 $ary = $self->maybe_local(@_,
5491 $self->stash_variable('@',
5492 $self->gv_name($gv),
5496 # Skip the last kid when OPf_STACKED is set, since it is the array
5498 for (; !null($stacked ? $kid->sibling : $kid); $kid = $kid->sibling) {
5499 push @exprs, $self->deparse($kid, 6);
5502 # handle special case of split(), and split(' ') that compiles to /\s+/
5503 # Under 5.10, the reflags may be undef if the split regexp isn't a constant
5504 # Under 5.17.5-5.17.9, the special flag is on split itself.
5506 if ( $op->flags & OPf_SPECIAL
5508 $kid->flags & OPf_SPECIAL
5509 and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
5510 : ($kid->reflags || 0) & RXf_SKIPWHITE()
5517 $expr = "split(" . join(", ", @exprs) . ")";
5519 return $self->maybe_parens("$ary = $expr", $cx, 7);
5525 # oxime -- any of various compounds obtained chiefly by the action of
5526 # hydroxylamine on aldehydes and ketones and characterized by the
5527 # bivalent grouping C=NOH [Webster's Tenth]
5530 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
5531 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
5532 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
5533 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi', 'rogue',
5534 'sir', 'rise', 'smore', 'more', 'seer', 'rome', 'gore', 'grim', 'grime',
5535 'or', 'rose', 'rosie');
5540 my $kid = $op->first;
5541 my($binop, $var, $re, $repl) = ("", "", "", "");
5542 if ($op->flags & OPf_STACKED) {
5544 $var = $self->deparse($kid, 20);
5545 $kid = $kid->sibling;
5547 elsif (my $targ = $op->targ) {
5549 $var = $self->padname($targ);
5552 my $pmflags = $op->pmflags;
5553 if (null($op->pmreplroot)) {
5555 $kid = $kid->sibling;
5557 $repl = $op->pmreplroot->first; # skip substcont
5559 while ($repl->name eq "entereval") {
5560 $repl = $repl->first;
5564 local $self->{in_subst_repl} = 1;
5565 if ($pmflags & PMf_EVAL) {
5566 $repl = $self->deparse($repl->first, 0);
5568 $repl = $self->dq($repl);
5571 if (not null my $code_list = $op->code_list) {
5572 $re = $self->code_list($code_list);
5573 } elsif (null $kid) {
5574 $re = re_uninterp(escape_re(re_unback($op->precomp)));
5576 ($re) = $self->regcomp($kid, 1);
5578 $flags .= "r" if $pmflags & PMf_NONDESTRUCT;
5579 $flags .= "e" if $pmflags & PMf_EVAL;
5580 $flags .= $self->re_flags($op);
5581 $flags = join '', sort split //, $flags;
5582 $flags = $substwords{$flags} if $substwords{$flags};
5583 my $core_s = $self->keyword("s"); # maybe CORE::s
5585 return $self->maybe_parens("$var =~ $core_s"
5586 . double_delim($re, $repl) . $flags,
5589 return "$core_s". double_delim($re, $repl) . $flags;
5593 sub is_lexical_subs {
5596 return 0 if $op->name !~ /\A(?:introcv|clonecv)\z/;
5601 # Pretend these two ops do not exist. The perl parser adds them to the
5602 # beginning of any block containing my-sub declarations, whereas we handle
5603 # the subs in pad_subs and next_todo.
5604 *pp_clonecv = *pp_introcv;
5608 # For now, deparsing doesn't worry about the distinction between introcv
5609 # and clonecv, so pretend this op doesn't exist:
5616 return $self->padany($op);
5619 my %lvref_funnies = (
5620 OPpLVREF_SV, => '$',
5621 OPpLVREF_AV, => '@',
5622 OPpLVREF_HV, => '%',
5623 OPpLVREF_CV, => '&',
5627 my ($self, $op, $cx) = @_;
5629 if ($op->private & OPpLVREF_ELEM) {
5630 $left = $op->first->sibling;
5631 $left = maybe_local(@_, elem($self, $left, undef,
5632 $left->targ == OP_AELEM
5635 } elsif ($op->flags & OPf_STACKED) {
5636 $left = maybe_local(@_,
5637 $lvref_funnies{$op->private & OPpLVREF_TYPE}
5638 . $self->deparse($op->first->sibling));
5642 my $right = $self->deparse_binop_right($op, $op->first, 7);
5643 return $self->maybe_parens("\\$left = $right", $cx, 7);
5647 my ($self, $op, $cx) = @_;
5649 if ($op->private & OPpLVREF_ELEM) {
5650 $code = $op->first->name =~ /av\z/ ? &pp_aelem : &pp_helem;
5651 } elsif ($op->flags & OPf_STACKED) {
5652 $code = maybe_local(@_,
5653 $lvref_funnies{$op->private & OPpLVREF_TYPE}
5654 . $self->deparse($op->first));
5662 my ($self, $op, $cx) = @_;
5663 '\\' . ($op->last->name =~ /av\z/ ? &pp_aslice : &pp_hslice);
5667 my ($self, $op, $cx) = @_;
5668 '\\(' . ($op->flags & OPf_STACKED
5669 ? maybe_local(@_, rv2x(@_, "\@"))
5678 B::Deparse - Perl compiler backend to produce perl code
5682 B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
5683 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
5687 B::Deparse is a backend module for the Perl compiler that generates
5688 perl source code, based on the internal compiled structure that perl
5689 itself creates after parsing a program. The output of B::Deparse won't
5690 be exactly the same as the original source, since perl doesn't keep
5691 track of comments or whitespace, and there isn't a one-to-one
5692 correspondence between perl's syntactical constructions and their
5693 compiled form, but it will often be close. When you use the B<-p>
5694 option, the output also includes parentheses even when they are not
5695 required by precedence, which can make it easy to see if perl is
5696 parsing your expressions the way you intended.
5698 While B::Deparse goes to some lengths to try to figure out what your
5699 original program was doing, some parts of the language can still trip
5700 it up; it still fails even on some parts of Perl's own test suite. If
5701 you encounter a failure other than the most common ones described in
5702 the BUGS section below, you can help contribute to B::Deparse's
5703 ongoing development by submitting a bug report with a small
5708 As with all compiler backend options, these must follow directly after
5709 the '-MO=Deparse', separated by a comma but not any white space.
5715 Output data values (when they appear as constants) using Data::Dumper.
5716 Without this option, B::Deparse will use some simple routines of its
5717 own for the same purpose. Currently, Data::Dumper is better for some
5718 kinds of data (such as complex structures with sharing and
5719 self-reference) while the built-in routines are better for others
5720 (such as odd floating-point values).
5724 Normally, B::Deparse deparses the main code of a program, and all the subs
5725 defined in the same file. To include subs defined in
5726 other files, pass the B<-f> option with the filename.
5727 You can pass the B<-f> option several times, to
5728 include more than one secondary file. (Most of the time you don't want to
5729 use it at all.) You can also use this option to include subs which are
5730 defined in the scope of a B<#line> directive with two parameters.
5734 Add '#line' declarations to the output based on the line and file
5735 locations of the original code.
5739 Print extra parentheses. Without this option, B::Deparse includes
5740 parentheses in its output only when they are needed, based on the
5741 structure of your program. With B<-p>, it uses parentheses (almost)
5742 whenever they would be legal. This can be useful if you are used to
5743 LISP, or if you want to see how perl parses your input. If you say
5745 if ($var & 0x7f == 65) {print "Gimme an A!"}
5746 print ($which ? $a : $b), "\n";
5747 $name = $ENV{USER} or "Bob";
5749 C<B::Deparse,-p> will print
5752 print('Gimme an A!')
5754 (print(($which ? $a : $b)), '???');
5755 (($name = $ENV{'USER'}) or '???')
5757 which probably isn't what you intended (the C<'???'> is a sign that
5758 perl optimized away a constant value).
5762 Disable prototype checking. With this option, all function calls are
5763 deparsed as if no prototype was defined for them. In other words,
5765 perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
5774 making clear how the parameters are actually passed to C<foo>.
5778 Expand double-quoted strings into the corresponding combinations of
5779 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
5782 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
5786 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
5787 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
5789 Note that the expanded form represents the way perl handles such
5790 constructions internally -- this option actually turns off the reverse
5791 translation that B::Deparse usually does. On the other hand, note that
5792 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
5793 of $y into a string before doing the assignment.
5795 =item B<-s>I<LETTERS>
5797 Tweak the style of B::Deparse's output. The letters should follow
5798 directly after the 's', with no space or punctuation. The following
5799 options are available:
5805 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
5822 The default is not to cuddle.
5826 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
5830 Use tabs for each 8 columns of indent. The default is to use only spaces.
5831 For instance, if the style options are B<-si4T>, a line that's indented
5832 3 times will be preceded by one tab and four spaces; if the options were
5833 B<-si8T>, the same line would be preceded by three tabs.
5835 =item B<v>I<STRING>B<.>
5837 Print I<STRING> for the value of a constant that can't be determined
5838 because it was optimized away (mnemonic: this happens when a constant
5839 is used in B<v>oid context). The end of the string is marked by a period.
5840 The string should be a valid perl expression, generally a constant.
5841 Note that unless it's a number, it probably needs to be quoted, and on
5842 a command line quotes need to be protected from the shell. Some
5843 conventional values include 0, 1, 42, '', 'foo', and
5844 'Useless use of constant omitted' (which may need to be
5845 B<-sv"'Useless use of constant omitted'.">
5846 or something similar depending on your shell). The default is '???'.
5847 If you're using B::Deparse on a module or other file that's require'd,
5848 you shouldn't use a value that evaluates to false, since the customary
5849 true constant at the end of a module will be in void context when the
5850 file is compiled as a main program.
5856 Expand conventional syntax constructions into equivalent ones that expose
5857 their internal operation. I<LEVEL> should be a digit, with higher values
5858 meaning more expansion. As with B<-q>, this actually involves turning off
5859 special cases in B::Deparse's normal operations.
5861 If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
5862 while loops with continue blocks; for instance
5864 for ($i = 0; $i < 10; ++$i) {
5877 Note that in a few cases this translation can't be perfectly carried back
5878 into the source code -- if the loop's initializer declares a my variable,
5879 for instance, it won't have the correct scope outside of the loop.
5881 If I<LEVEL> is at least 5, C<use> declarations will be translated into
5882 C<BEGIN> blocks containing calls to C<require> and C<import>; for
5892 'strict'->import('refs')
5896 If I<LEVEL> is at least 7, C<if> statements will be translated into
5897 equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
5899 print 'hi' if $nice;
5911 $nice and print 'hi';
5912 $nice and do { print 'hi' };
5913 $nice ? do { print 'hi' } : do { print 'bye' };
5915 Long sequences of elsifs will turn into nested ternary operators, which
5916 B::Deparse doesn't know how to indent nicely.
5920 =head1 USING B::Deparse AS A MODULE
5925 $deparse = B::Deparse->new("-p", "-sC");
5926 $body = $deparse->coderef2text(\&func);
5927 eval "sub func $body"; # the inverse operation
5931 B::Deparse can also be used on a sub-by-sub basis from other perl
5936 $deparse = B::Deparse->new(OPTIONS)
5938 Create an object to store the state of a deparsing operation and any
5939 options. The options are the same as those that can be given on the
5940 command line (see L</OPTIONS>); options that are separated by commas
5941 after B<-MO=Deparse> should be given as separate strings.
5943 =head2 ambient_pragmas
5945 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
5947 The compilation of a subroutine can be affected by a few compiler
5948 directives, B<pragmas>. These are:
5962 Assigning to the special variable $[
5982 Ordinarily, if you use B::Deparse on a subroutine which has
5983 been compiled in the presence of one or more of these pragmas,
5984 the output will include statements to turn on the appropriate
5985 directives. So if you then compile the code returned by coderef2text,
5986 it will behave the same way as the subroutine which you deparsed.
5988 However, you may know that you intend to use the results in a
5989 particular context, where some pragmas are already in scope. In
5990 this case, you use the B<ambient_pragmas> method to describe the
5991 assumptions you wish to make.
5993 Not all of the options currently have any useful effect. See
5994 L</BUGS> for more details.
5996 The parameters it accepts are:
6002 Takes a string, possibly containing several values separated
6003 by whitespace. The special values "all" and "none" mean what you'd
6006 $deparse->ambient_pragmas(strict => 'subs refs');
6010 Takes a number, the value of the array base $[.
6011 Cannot be non-zero on Perl 5.15.3 or later.
6019 If the value is true, then the appropriate pragma is assumed to
6020 be in the ambient scope, otherwise not.
6024 Takes a string, possibly containing a whitespace-separated list of
6025 values. The values "all" and "none" are special. It's also permissible
6026 to pass an array reference here.
6028 $deparser->ambient_pragmas(re => 'eval');
6033 Takes a string, possibly containing a whitespace-separated list of
6034 values. The values "all" and "none" are special, again. It's also
6035 permissible to pass an array reference here.
6037 $deparser->ambient_pragmas(warnings => [qw[void io]]);
6039 If one of the values is the string "FATAL", then all the warnings
6040 in that list will be considered fatal, just as with the B<warnings>
6041 pragma itself. Should you need to specify that some warnings are
6042 fatal, and others are merely enabled, you can pass the B<warnings>
6045 $deparser->ambient_pragmas(
6047 warnings => [FATAL => qw/void io/],
6050 See L<warnings> for more information about lexical warnings.
6056 These two parameters are used to specify the ambient pragmas in
6057 the format used by the special variables $^H and ${^WARNING_BITS}.
6059 They exist principally so that you can write code like:
6061 { my ($hint_bits, $warning_bits);
6062 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
6063 $deparser->ambient_pragmas (
6064 hint_bits => $hint_bits,
6065 warning_bits => $warning_bits,
6069 which specifies that the ambient pragmas are exactly those which
6070 are in scope at the point of calling.
6074 This parameter is used to specify the ambient pragmas which are
6075 stored in the special hash %^H.
6081 $body = $deparse->coderef2text(\&func)
6082 $body = $deparse->coderef2text(sub ($$) { ... })
6084 Return source code for the body of a subroutine (a block, optionally
6085 preceded by a prototype in parens), given a reference to the
6086 sub. Because a subroutine can have no names, or more than one name,
6087 this method doesn't return a complete subroutine definition -- if you
6088 want to eval the result, you should prepend "sub subname ", or "sub "
6089 for an anonymous function constructor. Unless the sub was defined in
6090 the main:: package, the code will include a package declaration.
6098 In Perl 5.20 and earlier, the only pragmas to
6099 be completely supported are: C<use warnings>,
6100 C<use strict>, C<use bytes>, C<use integer>
6101 and C<use feature>. (C<$[>, which
6102 behaves like a pragma, is also supported.)
6104 Excepting those listed above, we're currently unable to guarantee that
6105 B::Deparse will produce a pragma at the correct point in the program.
6106 (Specifically, pragmas at the beginning of a block often appear right
6107 before the start of the block instead.)
6108 Since the effects of pragmas are often lexically scoped, this can mean
6109 that the pragma holds sway over a different portion of the program
6110 than in the input file.
6114 In fact, the above is a specific instance of a more general problem:
6115 we can't guarantee to produce BEGIN blocks or C<use> declarations in
6116 exactly the right place. So if you use a module which affects compilation
6117 (such as by over-riding keywords, overloading constants or whatever)
6118 then the output code might not work as intended.
6120 This is the most serious problem in Perl 5.20 and earlier. Fixing this
6121 required internal changes in Perl 5.22.
6125 Some constants don't print correctly either with or without B<-d>.
6126 For instance, neither B::Deparse nor Data::Dumper know how to print
6127 dual-valued scalars correctly, as in:
6129 use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
6131 use constant H => { "#" => 1 }; H->{"#"};
6135 An input file that uses source filtering probably won't be deparsed into
6136 runnable code, because it will still include the B<use> declaration
6137 for the source filtering module, even though the code that is
6138 produced is already ordinary Perl which shouldn't be filtered again.
6142 Optimized-away statements are rendered as
6143 '???'. This includes statements that
6144 have a compile-time side-effect, such as the obscure
6148 which is not, consequently, deparsed correctly.
6150 foreach my $i (@_) { 0 }
6152 foreach my $i (@_) { '???' }
6156 Lexical (my) variables declared in scopes external to a subroutine
6157 appear in code2ref output text as package variables. This is a tricky
6158 problem, as perl has no native facility for referring to a lexical variable
6159 defined within a different scope, although L<PadWalker> is a good start.
6161 See also L<Data::Dump::Streamer>, which combines B::Deparse and
6162 L<PadWalker> to serialize closures properly.
6166 There are probably many more bugs on non-ASCII platforms (EBCDIC).
6170 Prior to Perl 5.22, lexical C<my> subroutines were not deparsed properly.
6171 They were emitted as pure declarations, sometimes in the wrong place.
6172 Lexical C<state> subroutines were not deparsed at all.
6178 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version
6179 by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from
6180 Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
6181 Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael