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
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);
26 use vars qw/$AUTOLOAD/;
31 # List version-specific constants here.
32 # Easiest way to keep this code portable between version looks to
33 # be to fake up a dummy constant that will never actually be true.
34 foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
35 OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE
36 RXf_PMf_CHARSET RXf_PMf_KEEPCOPY
37 CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
38 PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES
39 OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV
40 OPpLVREF_CV OPpLVREF_ELEM SVpad_STATE)) {
43 *{$_} = sub () {0} unless *{$_}{CODE};
47 # Changes between 0.50 and 0.51:
48 # - fixed nulled leave with live enter in sort { }
49 # - fixed reference constants (\"str")
50 # - handle empty programs gracefully
51 # - handle infinite loops (for (;;) {}, while (1) {})
52 # - differentiate between 'for my $x ...' and 'my $x; for $x ...'
53 # - various minor cleanups
54 # - moved globals into an object
55 # - added '-u', like B::C
56 # - package declarations using cop_stash
57 # - subs, formats and code sorted by cop_seq
58 # Changes between 0.51 and 0.52:
59 # - added pp_threadsv (special variables under USE_5005THREADS)
60 # - added documentation
61 # Changes between 0.52 and 0.53:
62 # - many changes adding precedence contexts and associativity
63 # - added '-p' and '-s' output style options
64 # - various other minor fixes
65 # Changes between 0.53 and 0.54:
66 # - added support for new 'for (1..100)' optimization,
68 # Changes between 0.54 and 0.55:
69 # - added support for new qr// construct
70 # - added support for new pp_regcreset OP
71 # Changes between 0.55 and 0.56:
72 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
73 # - fixed $# on non-lexicals broken in last big rewrite
74 # - added temporary fix for change in opcode of OP_STRINGIFY
75 # - fixed problem in 0.54's for() patch in 'for (@ary)'
76 # - fixed precedence in conditional of ?:
77 # - tweaked list paren elimination in 'my($x) = @_'
78 # - made continue-block detection trickier wrt. null ops
79 # - fixed various prototype problems in pp_entersub
80 # - added support for sub prototypes that never get GVs
81 # - added unquoting for special filehandle first arg in truncate
82 # - print doubled rv2gv (a bug) as '*{*GV}' instead of illegal '**GV'
83 # - added semicolons at the ends of blocks
84 # - added -l '#line' declaration option -- fixes cmd/subval.t 27,28
85 # Changes between 0.56 and 0.561:
86 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
87 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
88 # Changes between 0.561 and 0.57:
89 # - stylistic changes to symbolic constant stuff
90 # - handled scope in s///e replacement code
91 # - added unquote option for expanding "" into concats, etc.
92 # - split method and proto parts of pp_entersub into separate functions
93 # - various minor cleanups
95 # - added parens in \&foo (patch by Albert Dvornik)
96 # Changes between 0.57 and 0.58:
97 # - fixed '0' statements that weren't being printed
98 # - added methods for use from other programs
99 # (based on patches from James Duncan and Hugo van der Sanden)
100 # - added -si and -sT to control indenting (also based on a patch from Hugo)
101 # - added -sv to print something else instead of '???'
102 # - preliminary version of utf8 tr/// handling
103 # Changes after 0.58:
104 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
105 # - added support for Hugo's new OP_SETSTATE (like nextstate)
106 # Changes between 0.58 and 0.59
107 # - added support for Chip's OP_METHOD_NAMED
108 # - added support for Ilya's OPpTARGET_MY optimization
109 # - elided arrows before '()' subscripts when possible
110 # Changes between 0.59 and 0.60
111 # - support for method attributes was added
112 # - some warnings fixed
113 # - separate recognition of constant subs
114 # - rewrote continue block handling, now recognizing for loops
115 # - added more control of expanding control structures
116 # Changes between 0.60 and 0.61 (mostly by Robin Houston)
118 # - support for pragmas and 'use'
119 # - support for the little-used $[ variable
120 # - support for __DATA__ sections
122 # - BEGIN, CHECK, INIT and END blocks
123 # - scoping of subroutine declarations fixed
124 # - compile-time output from the input program can be suppressed, so that the
125 # output is just the deparsed code. (a change to O.pm in fact)
126 # - our() declarations
127 # - *all* the known bugs are now listed in the BUGS section
128 # - comprehensive test mechanism (TEST -deparse)
129 # Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
132 # - support for command-line switches (-l, -0, etc.)
133 # Changes between 0.63 and 0.64
134 # - support for //, CHECK blocks, and assertions
135 # - improved handling of foreach loops and lexicals
136 # - option to use Data::Dumper for constants
138 # - discovered lots more bugs not yet fixed
142 # Changes between 0.72 and 0.73
143 # - support new switch constructs
146 # (See also BUGS section at the end of this file)
148 # - finish tr/// changes
149 # - add option for even more parens (generalize \&foo change)
150 # - left/right context
151 # - copy comments (look at real text with $^P?)
152 # - avoid semis in one-statement blocks
153 # - associativity of &&=, ||=, ?:
154 # - ',' => '=>' (auto-unquote?)
155 # - break long lines ("\r" as discretionary break?)
156 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
157 # - more style options: brace style, hex vs. octal, quotes, ...
158 # - print big ints as hex/octal instead of decimal (heuristic?)
159 # - handle 'my $x if 0'?
160 # - version using op_next instead of op_first/sibling?
161 # - avoid string copies (pass arrays, one big join?)
164 # Current test.deparse failures
165 # comp/hints 6 - location of BEGIN blocks wrt. block openings
166 # run/switchI 1 - missing -I switches entirely
167 # perl -Ifoo -e 'print @INC'
168 # op/caller 2 - warning mask propagates backwards before warnings::register
169 # 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
170 # op/getpid 2 - can't assign to shared my() declaration (threads only)
171 # 'my $x : shared = 5'
172 # op/override 7 - parens on overridden require change v-string interpretation
173 # 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
174 # c.f. 'BEGIN { *f = sub {0} }; f 2'
175 # op/pat 774 - losing Unicode-ness of Latin1-only strings
176 # 'use charnames ":short"; $x="\N{latin:a with acute}"'
177 # op/recurse 12 - missing parens on recursive call makes it look like method
179 # op/subst 90 - inconsistent handling of utf8 under "use utf8"
180 # op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
181 # op/tiehandle compile - "use strict" deparsed in the wrong place
183 # ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
184 # ext/Data/Dumper/t/dumper compile
185 # ext/DB_file/several
187 # ext/Ernno/Errno warnings
188 # ext/IO/lib/IO/t/io_sel 23
189 # ext/PerlIO/t/encoding compile
190 # ext/POSIX/t/posix 6
191 # ext/Socket/Socket 8
192 # ext/Storable/t/croak compile
193 # lib/Attribute/Handlers/t/multi compile
194 # lib/bignum/ several
198 # lib/ExtUtils/t/bytes 4
199 # lib/File/DosGlob compile
200 # lib/Filter/Simple/t/data 1
201 # lib/Math/BigInt/t/constant 1
202 # lib/Net/t/config Deparse-warning
203 # lib/overload compile
204 # lib/Switch/ several
206 # lib/Test/Simple several
208 # lib/Tie/File/t/29_downcopy 5
211 # Object fields (were globals):
214 # (local($a), local($b)) and local($a, $b) have the same internal
215 # representation but the short form looks better. We notice we can
216 # use a large-scale local when checking the list, but need to prevent
217 # individual locals too. This hash holds the addresses of OPs that
218 # have already had their local-ness accounted for. The same thing
222 # CV for current sub (or main program) being deparsed
225 # Cached hash of lexical variables for curcv: keys are
226 # names prefixed with "m" or "o" (representing my/our), and
227 # each value is an array with two elements indicating the cop_seq
228 # of scopes in which a var of that name is valid and a third ele-
229 # ment referencing the pad name.
232 # COP for statement being deparsed
235 # name of the current package for deparsed code
238 # array of [cop_seq, CV, is_format?] for subs and formats we still
239 # want to deparse. Lexical subs have one more element, giving the pad
240 # name thingy, and CV may be undef, indicating a stub declaration.
243 # as above, but [name, prototype] for subs that never got a GV
245 # subs_done, forms_done:
246 # keys are addresses of GVs for subs and formats we've already
247 # deparsed (or at least put into subs_todo)
250 # keys are names of subs for which we've printed declarations.
251 # That means we can omit parentheses from the arguments. It also means we
252 # need to put CORE:: on core functions of the same name.
255 # Keeps track of fully qualified names of all deparsed subs.
258 # True when deparsing the replacement part of a substitution.
261 # True when deparsing the argument to \.
266 # cuddle: ' ' or '\n', depending on -sC
271 # A little explanation of how precedence contexts and associativity
274 # deparse() calls each per-op subroutine with an argument $cx (short
275 # for context, but not the same as the cx* in the perl core), which is
276 # a number describing the op's parents in terms of precedence, whether
277 # they're inside an expression or at statement level, etc. (see
278 # chart below). When ops with children call deparse on them, they pass
279 # along their precedence. Fractional values are used to implement
280 # associativity ('($x + $y) + $z' => '$x + $y + $y') and related
281 # parentheses hacks. The major disadvantage of this scheme is that
282 # it doesn't know about right sides and left sides, so say if you
283 # assign a listop to a variable, it can't tell it's allowed to leave
284 # the parens off the listop.
287 # 26 [TODO] inside interpolation context ("")
288 # 25 left terms and list operators (leftward)
292 # 21 right ! ~ \ and unary + and -
297 # 16 nonassoc named unary operators
298 # 15 nonassoc < > <= >= lt gt le ge
299 # 14 nonassoc == != <=> eq ne cmp
306 # 7 right = += -= *= etc.
308 # 5 nonassoc list operators (rightward)
312 # 1 statement modifiers
313 # 0.5 statements, but still print scopes as do { ... }
317 # Nonprinting characters with special meaning:
318 # \cS - steal parens (see maybe_parens_unop)
319 # \n - newline and indent
320 # \t - increase indent
321 # \b - decrease indent ('outdent')
322 # \f - flush left (no indent)
323 # \cK - kill following semicolon, if any
327 BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
328 custom nextstate dbstate ]) {
329 eval "sub OP_\U$_ () { " . opnumber($_) . "}"
332 # _pessimise_walk(): recursively walk the optree of a sub,
333 # possibly undoing optimisations along the way.
335 sub _pessimise_walk {
336 my ($self, $startop) = @_;
338 return unless $$startop;
340 for ($op = $startop; $$op; $prevop = $op, $op = $op->sibling) {
341 my $ppname = $op->name;
343 # pessimisations start here
345 if ($ppname eq "padrange") {
347 # the original optimisation either (1) changed this:
348 # pushmark -> (various pad and list and null ops) -> the_rest
349 # or (2), for the = @_ case, changed this:
350 # pushmark -> gv[_] -> rv2av -> (pad stuff) -> the_rest
352 # padrange ----------------------------------------> the_rest
353 # so we just need to convert the padrange back into a
354 # pushmark, and in case (1), set its op_next to op_sibling,
355 # which is the head of the original chain of optimised-away
356 # pad ops, or for (2), set it to sibling->first, which is
357 # the original gv[_].
359 $B::overlay->{$$op} = {
362 private => ($op->private & OPpLVAL_INTRO),
366 # pessimisations end here
368 if (class($op) eq 'PMOP'
369 && ref($op->pmreplroot)
370 && ${$op->pmreplroot}
371 && $op->pmreplroot->isa( 'B::OP' ))
373 $self-> _pessimise_walk($op->pmreplroot);
376 if ($op->flags & OPf_KIDS) {
377 $self-> _pessimise_walk($op->first);
384 # _pessimise_walk_exe(): recursively walk the op_next chain of a sub,
385 # possibly undoing optimisations along the way.
387 sub _pessimise_walk_exe {
388 my ($self, $startop, $visited) = @_;
390 return unless $$startop;
391 return if $visited->{$$startop};
393 for ($op = $startop; $$op; $prevop = $op, $op = $op->next) {
394 last if $visited->{$$op};
395 $visited->{$$op} = 1;
396 my $ppname = $op->name;
398 /^((and|d?or)(assign)?|(map|grep)while|range|cond_expr|once)$/
399 # entertry is also a logop, but its op_other invariably points
400 # into the same chain as the main execution path, so we skip it
402 $self->_pessimise_walk_exe($op->other, $visited);
404 elsif ($ppname eq "subst") {
405 $self->_pessimise_walk_exe($op->pmreplstart, $visited);
407 elsif ($ppname =~ /^(enter(loop|iter))$/) {
408 # redoop and nextop will already be covered by the main block
410 $self->_pessimise_walk_exe($op->lastop, $visited);
413 # pessimisations start here
417 # Go through an optree and "remove" some optimisations by using an
418 # overlay to selectively modify or un-null some ops. Deparsing in the
419 # absence of those optimisations is then easier.
421 # Note that older optimisations are not removed, as Deparse was already
422 # written to recognise them before the pessimise/overlay system was added.
425 my ($self, $root, $start) = @_;
427 # walk tree in root-to-branch order
428 $self->_pessimise_walk($root);
431 # walk tree in execution order
432 $self->_pessimise_walk_exe($start, \%visited);
438 return class($op) eq "NULL";
443 my($cv, $is_form) = @_;
444 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
446 if ($cv->OUTSIDE_SEQ) {
447 $seq = $cv->OUTSIDE_SEQ;
448 } elsif (!null($cv->START) and is_state($cv->START)) {
449 $seq = $cv->START->cop_seq;
453 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
454 unless ($is_form || class($cv->STASH) eq 'SPECIAL') {
455 $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1;
461 my $ent = shift @{$self->{'subs_todo'}};
463 if ($ent->[3]) { # lexical sub
466 # At this point, we may not yet have deparsed the hints that allow
467 # lexical subroutines to be recognized. So adjust the current
468 # hints and deparse them.
469 # When lex subs cease being experimental, we should be able to
472 local $^H = $self->{'hints'};
473 local %^H = %{ $self->{'hinthash'} || {} };
474 local ${^WARNING_BITS} = $self->{'warnings'};
475 feature->import("lexical_subs");
476 warnings->unimport("experimental::lexical_subs");
477 # Here we depend on the fact that individual features
478 # will always set the feature bundle to ‘custom’
479 # (== $feature::hint_mask). If we had another specific bundle
480 # enabled previously, normalise it.
481 if (($self->{'hints'} & $feature::hint_mask)
482 != $feature::hint_mask)
484 if ($self->{'hinthash'}) {
485 delete $self->{'hinthash'}{$_}
486 for grep /^feature_/, keys %{$self->{'hinthash'}};
488 else { $self->{'hinthash'} = {} }
490 = _features_from_bundle(@$self{'hints','hinthash'});
492 push @text, $self->declare_hinthash($self->{'hinthash'}, \%^H,
493 $self->{indent_size}, $^H);
494 push @text, $self->declare_warnings($self->{'warnings'},
496 unless ($self->{'warnings'} // 'u')
497 eq (${^WARNING_BITS } // 'u');
498 $self->{'warnings'} = ${^WARNING_BITS};
499 $self->{'hints'} = $^H;
500 $self->{'hinthash'} = {%^H};
503 # Now emit the sub itself.
504 my $padname = $ent->[3];
505 my $flags = $padname->FLAGS;
507 !$cv || $ent->[0] <= $padname->COP_SEQ_RANGE_LOW
508 ? $self->keyword($flags & SVpad_OUR
510 : $flags & SVpad_STATE
514 # XXX We would do $self->keyword("sub"), but ‘my CORE::sub’
515 # doesn’t work and ‘my sub’ ignores a &sub in scope. I.e.,
516 # we have a core bug here.
517 push @text, "sub " . substr $padname->PVX, 1;
520 push @text, " " . $self->deparse_sub($cv);
521 $text[-1] =~ s/ ;$/;/;
527 return join "", @text;
530 my $name = $self->gv_name($gv);
532 return $self->keyword("format") . " $name =\n"
533 . $self->deparse_format($ent->[1]). "\n";
535 $self->{'subs_declared'}{$name} = 1;
536 if ($name eq "BEGIN") {
537 my $use_dec = $self->begin_is_use($cv);
538 if (defined ($use_dec) and $self->{'expand'} < 5) {
539 return () if 0 == length($use_dec);
540 $use_dec =~ s/^(use|no)\b/$self->keyword($1)/e;
545 if ($self->{'linenums'}) {
546 my $line = $gv->LINE;
547 my $file = $gv->FILE;
548 $l = "\n\f#line $line \"$file\"\n";
552 if (class($cv->STASH) ne "SPECIAL") {
553 $stash = $cv->STASH->NAME;
554 if ($stash ne $self->{'curstash'}) {
555 $p = $self->keyword("package") . " $stash;\n";
556 $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
557 $self->{'curstash'} = $stash;
560 if ( $name !~ /::/ and $self->lex_in_scope("&$name")
561 || $self->lex_in_scope("&$name", 1) )
563 $name = "$self->{'curstash'}::$name";
564 } elsif (defined $stash) {
565 $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
567 return "${p}${l}" . $self->keyword("sub") . " $name "
568 . $self->deparse_sub($cv);
572 # Return a "use" declaration for this BEGIN block, if appropriate
574 my ($self, $cv) = @_;
575 my $root = $cv->ROOT;
576 local @$self{qw'curcv curcvlex'} = ($cv);
577 local $B::overlay = {};
578 $self->pessimise($root, $cv->START);
580 #B::walkoptree($cv->ROOT, "debug");
581 my $lineseq = $root->first;
582 return if $lineseq->name ne "lineseq";
584 my $req_op = $lineseq->first->sibling;
585 return if $req_op->name ne "require";
588 if ($req_op->first->private & OPpCONST_BARE) {
589 # Actually it should always be a bareword
590 $module = $self->const_sv($req_op->first)->PV;
591 $module =~ s[/][::]g;
595 $module = $self->const($self->const_sv($req_op->first), 6);
599 my $version_op = $req_op->sibling;
600 return if class($version_op) eq "NULL";
601 if ($version_op->name eq "lineseq") {
602 # We have a version parameter; skip nextstate & pushmark
603 my $constop = $version_op->first->next->next;
605 return unless $self->const_sv($constop)->PV eq $module;
606 $constop = $constop->sibling;
607 $version = $self->const_sv($constop);
608 if (class($version) eq "IV") {
609 $version = $version->int_value;
610 } elsif (class($version) eq "NV") {
611 $version = $version->NV;
612 } elsif (class($version) ne "PVMG") {
613 # Includes PVIV and PVNV
614 $version = $version->PV;
616 # version specified as a v-string
617 $version = 'v'.join '.', map ord, split //, $version->PV;
619 $constop = $constop->sibling;
620 return if $constop->name ne "method_named";
621 return if $self->meth_sv($constop)->PV ne "VERSION";
624 $lineseq = $version_op->sibling;
625 return if $lineseq->name ne "lineseq";
626 my $entersub = $lineseq->first->sibling;
627 if ($entersub->name eq "stub") {
628 return "use $module $version ();\n" if defined $version;
629 return "use $module ();\n";
631 return if $entersub->name ne "entersub";
633 # See if there are import arguments
636 my $svop = $entersub->first->sibling; # Skip over pushmark
637 return unless $self->const_sv($svop)->PV eq $module;
639 # Pull out the arguments
640 for ($svop=$svop->sibling; index($svop->name, "method_") != 0;
641 $svop = $svop->sibling) {
642 $args .= ", " if length($args);
643 $args .= $self->deparse($svop, 6);
647 my $method_named = $svop;
648 return if $method_named->name ne "method_named";
649 my $method_name = $self->meth_sv($method_named)->PV;
651 if ($method_name eq "unimport") {
655 # Certain pragmas are dealt with using hint bits,
656 # so we ignore them here
657 if ($module eq 'strict' || $module eq 'integer'
658 || $module eq 'bytes' || $module eq 'warnings'
659 || $module eq 'feature') {
663 if (defined $version && length $args) {
664 return "$use $module $version ($args);\n";
665 } elsif (defined $version) {
666 return "$use $module $version;\n";
667 } elsif (length $args) {
668 return "$use $module ($args);\n";
670 return "$use $module;\n";
675 my ($self, $pack, $seen) = @_;
677 if (!defined $pack) {
682 $pack =~ s/(::)?$/::/;
684 $stash = \%{"main::$pack"};
688 $INC{"overload.pm"} ? overload::StrVal($stash) : $stash
690 my %stash = svref_2object($stash)->ARRAY;
691 while (my ($key, $val) = each %stash) {
692 my $class = class($val);
693 if ($class eq "PV") {
694 # Just a prototype. As an ugly but fairly effective way
695 # to find out if it belongs here is to see if the AUTOLOAD
696 # (if any) for the stash was defined in one of our files.
697 my $A = $stash{"AUTOLOAD"};
698 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
699 && class($A->CV) eq "CV") {
701 next unless $AF eq $0 || exists $self->{'files'}{$AF};
703 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
704 } elsif ($class eq "IV" && !($val->FLAGS & SVf_ROK)) {
705 # Just a name. As above.
706 # But skip proxy constant subroutines, as some form of perl-space
707 # visible code must have created them, be it a use statement, or
708 # some direct symbol-table manipulation code that we will Deparse
709 my $A = $stash{"AUTOLOAD"};
710 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
711 && class($A->CV) eq "CV") {
713 next unless $AF eq $0 || exists $self->{'files'}{$AF};
715 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
716 } elsif ($class eq "IV") {
717 # A reference. Dump this if it is a reference to a CV.
718 if (class(my $cv = $val->RV) eq "CV") {
721 } elsif ($class eq "GV") {
722 if (class(my $cv = $val->CV) ne "SPECIAL") {
723 next if $self->{'subs_done'}{$$val}++;
724 next if $$val != ${$cv->GV}; # Ignore imposters
727 if (class(my $cv = $val->FORM) ne "SPECIAL") {
728 next if $self->{'forms_done'}{$$val}++;
729 next if $$val != ${$cv->GV}; # Ignore imposters
732 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
733 $self->stash_subs($pack . $key, $seen);
743 foreach $ar (@{$self->{'protos_todo'}}) {
744 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
745 push @ret, "sub " . $ar->[0] . "$proto;\n";
747 delete $self->{'protos_todo'};
755 while (length($opt = substr($opts, 0, 1))) {
757 $self->{'cuddle'} = " ";
758 $opts = substr($opts, 1);
759 } elsif ($opt eq "i") {
760 $opts =~ s/^i(\d+)//;
761 $self->{'indent_size'} = $1;
762 } elsif ($opt eq "T") {
763 $self->{'use_tabs'} = 1;
764 $opts = substr($opts, 1);
765 } elsif ($opt eq "v") {
766 $opts =~ s/^v([^.]*)(.|$)//;
767 $self->{'ex_const'} = $1;
774 my $self = bless {}, $class;
775 $self->{'cuddle'} = "\n";
776 $self->{'curcop'} = undef;
777 $self->{'curstash'} = "main";
778 $self->{'ex_const'} = "'???'";
779 $self->{'expand'} = 0;
780 $self->{'files'} = {};
781 $self->{'indent_size'} = 4;
782 $self->{'linenums'} = 0;
783 $self->{'parens'} = 0;
784 $self->{'subs_todo'} = [];
785 $self->{'unquote'} = 0;
786 $self->{'use_dumper'} = 0;
787 $self->{'use_tabs'} = 0;
789 $self->{'ambient_arybase'} = 0;
790 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
791 $self->{'ambient_hints'} = 0;
792 $self->{'ambient_hinthash'} = undef;
795 while (my $arg = shift @_) {
797 $self->{'use_dumper'} = 1;
798 require Data::Dumper;
799 } elsif ($arg =~ /^-f(.*)/) {
800 $self->{'files'}{$1} = 1;
801 } elsif ($arg eq "-l") {
802 $self->{'linenums'} = 1;
803 } elsif ($arg eq "-p") {
804 $self->{'parens'} = 1;
805 } elsif ($arg eq "-P") {
806 $self->{'noproto'} = 1;
807 } elsif ($arg eq "-q") {
808 $self->{'unquote'} = 1;
809 } elsif (substr($arg, 0, 2) eq "-s") {
810 $self->style_opts(substr $arg, 2);
811 } elsif ($arg =~ /^-x(\d)$/) {
812 $self->{'expand'} = $1;
819 # Mask out the bits that L<warnings::register> uses
822 $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
829 # Initialise the contextual information, either from
830 # defaults provided with the ambient_pragmas method,
831 # or from perl's own defaults otherwise.
835 $self->{'arybase'} = $self->{'ambient_arybase'};
836 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
837 ? $self->{'ambient_warnings'} & WARN_MASK
839 $self->{'hints'} = $self->{'ambient_hints'};
840 $self->{'hints'} &= 0xFF if $] < 5.009;
841 $self->{'hinthash'} = $self->{'ambient_hinthash'};
843 # also a convenient place to clear out subs_declared
844 delete $self->{'subs_declared'};
850 my $self = B::Deparse->new(@args);
851 # First deparse command-line args
852 if (defined $^I) { # deparse -i
853 print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
855 if ($^W) { # deparse -w
856 print qq(BEGIN { \$^W = $^W; }\n);
858 if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
859 my $fs = perlstring($/) || 'undef';
860 my $bs = perlstring($O::savebackslash) || 'undef';
861 print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
863 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
864 my @UNITCHECKs = B::unitcheck_av->isa("B::AV")
865 ? B::unitcheck_av->ARRAY
867 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
868 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
869 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
870 for my $block (@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs) {
871 $self->todo($block, 0);
874 local($SIG{"__DIE__"}) =
876 if ($self->{'curcop'}) {
877 my $cop = $self->{'curcop'};
878 my($line, $file) = ($cop->line, $cop->file);
879 print STDERR "While deparsing $file near line $line,\n";
882 $self->{'curcv'} = main_cv;
883 $self->{'curcvlex'} = undef;
884 print $self->print_protos;
885 @{$self->{'subs_todo'}} =
886 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
887 my $root = main_root;
888 local $B::overlay = {};
889 unless (null $root) {
890 $self->pad_subs($self->{'curcv'});
891 $self->pessimise($root, main_start);
892 print $self->indent($self->deparse_root($root)), "\n";
895 while (scalar(@{$self->{'subs_todo'}})) {
896 push @text, $self->next_todo;
898 print $self->indent(join("", @text)), "\n" if @text;
900 # Print __DATA__ section, if necessary
902 my $laststash = defined $self->{'curcop'}
903 ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
904 if (defined *{$laststash."::DATA"}{IO}) {
905 print $self->keyword("package") . " $laststash;\n"
906 unless $laststash eq $self->{'curstash'};
907 print $self->keyword("__DATA__") . "\n";
908 print readline(*{$laststash."::DATA"});
916 croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
919 return $self->indent($self->deparse_sub(svref_2object($sub)));
922 my %strict_bits = do {
924 map +($_ => strict::bits($_)), qw/refs subs vars/
927 sub ambient_pragmas {
929 my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
935 if ($name eq 'strict') {
938 if ($val eq 'none') {
939 $hint_bits &= $strict_bits{$_} for qw/refs subs vars/;
945 @names = qw/refs subs vars/;
951 @names = split' ', $val;
953 $hint_bits |= $strict_bits{$_} for @names;
956 elsif ($name eq '$[') {
957 if (OPpCONST_ARYBASE) {
960 croak "\$[ can't be non-zero on this perl" unless $val == 0;
964 elsif ($name eq 'integer'
966 || $name eq 'utf8') {
969 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
972 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
976 elsif ($name eq 're') {
978 if ($val eq 'none') {
979 $hint_bits &= ~re::bits(qw/taint eval/);
985 @names = qw/taint eval/;
991 @names = split' ',$val;
993 $hint_bits |= re::bits(@names);
996 elsif ($name eq 'warnings') {
997 if ($val eq 'none') {
998 $warning_bits = $warnings::NONE;
1007 @names = split/\s+/, $val;
1010 $warning_bits = $warnings::NONE if !defined ($warning_bits);
1011 $warning_bits |= warnings::bits(@names);
1014 elsif ($name eq 'warning_bits') {
1015 $warning_bits = $val;
1018 elsif ($name eq 'hint_bits') {
1022 elsif ($name eq '%^H') {
1027 croak "Unknown pragma type: $name";
1031 croak "The ambient_pragmas method expects an even number of args";
1034 $self->{'ambient_arybase'} = $arybase;
1035 $self->{'ambient_warnings'} = $warning_bits;
1036 $self->{'ambient_hints'} = $hint_bits;
1037 $self->{'ambient_hinthash'} = $hinthash;
1040 # This method is the inner loop, so try to keep it simple
1045 Carp::confess("Null op in deparse") if !defined($op)
1046 || class($op) eq "NULL";
1047 my $meth = "pp_" . $op->name;
1048 return $self->$meth($op, $cx);
1054 # Handle semicolons after sub declarations. There will be a \0 marker
1055 # after each sequence of subs. This:
1060 # needs to have the "\n\0;" removed, but the \n should be left if the
1061 # semicolon is not followed by one.
1062 $txt =~ s/(?<=\})(\n?)\0;(\n?)/$1 || $2 ? "\n" : ""/egg;
1063 # Remove any remaining markers
1065 my @lines = split(/\n/, $txt);
1069 for $line (@lines) {
1070 my $cmd = substr($line, 0, 1);
1071 if ($cmd eq "\t" or $cmd eq "\b") {
1072 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
1073 if ($self->{'use_tabs'}) {
1074 $leader = "\t" x ($level / 8) . " " x ($level % 8);
1076 $leader = " " x $level;
1078 $line = substr($line, 1);
1080 if (index($line, "\f") > 0) {
1083 if (substr($line, 0, 1) eq "\f") {
1084 $line = substr($line, 1); # no indent
1086 $line = $leader . $line;
1088 $line =~ s/\cK;?//g;
1090 return join("\n", @lines);
1094 my ($self, $cv) = @_;
1095 my $padlist = $cv->PADLIST;
1096 my @names = $padlist->ARRAYelt(0)->ARRAY;
1097 my @values = $padlist->ARRAYelt(1)->ARRAY;
1099 for my $ix (0.. $#names) { for $_ ($names[$ix]) {
1100 next if class($_) eq "SPECIAL";
1102 if ($name =~ /^&./) {
1103 my $low = $_->COP_SEQ_RANGE_LOW;
1104 my $flags = $_->FLAGS;
1105 if ($flags & SVpad_OUR) {
1106 push @todo, [$low, undef, 0, $_];
1107 # [seq, no cv, not format, padname]
1110 my $protocv = $flags & SVpad_STATE
1112 # XXX temporary future-compatibility; B::PADNAME will
1113 # have a PROTOCV method and no MAGIC method
1114 : $_->can("MAGIC") ? $_->MAGIC->OBJ : $_->PROTOCV;
1115 my $outseq = $protocv->OUTSIDE_SEQ;
1116 if ($outseq <= $low) {
1117 # defined before its name is visible, so it’s gotta be
1118 # declared and defined at once: my sub foo { ... }
1119 push @todo, [$low, $protocv, 0, $_];
1122 # declared and defined separately: my sub f; sub f { ... }
1123 push @todo, [$low, undef, 0, $_],
1124 [$outseq, $protocv, 0, $_];
1128 @{$self->{'subs_todo'}} =
1129 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo
1136 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
1137 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
1138 local $self->{'curcop'} = $self->{'curcop'};
1139 if ($cv->FLAGS & SVf_POK) {
1140 $proto = "(". $cv->PV . ") ";
1142 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
1144 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
1145 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
1146 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
1149 local($self->{'curcv'}) = $cv;
1150 local($self->{'curcvlex'});
1151 local(@$self{qw'curstash warnings hints hinthash'})
1152 = @$self{qw'curstash warnings hints hinthash'};
1154 my $root = $cv->ROOT;
1155 local $B::overlay = {};
1156 if (not null $root) {
1157 $self->pad_subs($cv);
1158 $self->pessimise($root, $cv->START);
1159 my $lineseq = $root->first;
1160 if ($lineseq->name eq "lineseq") {
1162 for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
1165 $body = $self->lineseq(undef, 0, @ops).";";
1166 my $scope_en = $self->find_scope_en($lineseq);
1167 if (defined $scope_en) {
1168 my $subs = join"", $self->seq_subs($scope_en);
1169 $body .= ";\n$subs" if length($subs);
1173 $body = $self->deparse($root->first, 0);
1177 my $sv = $cv->const_sv;
1179 # uh-oh. inlinable sub... format it differently
1180 return $proto . "{ " . $self->const($sv, 0) . " }\n";
1181 } else { # XSUB? (or just a declaration)
1185 return $proto ."{\n\t$body\n\b}" ."\n";
1188 sub deparse_format {
1192 local($self->{'curcv'}) = $form;
1193 local($self->{'curcvlex'});
1194 local($self->{'in_format'}) = 1;
1195 local(@$self{qw'curstash warnings hints hinthash'})
1196 = @$self{qw'curstash warnings hints hinthash'};
1197 my $op = $form->ROOT;
1198 local $B::overlay = {};
1199 $self->pessimise($op, $form->START);
1201 return "\f." if $op->first->name eq 'stub'
1202 || $op->first->name eq 'nextstate';
1203 $op = $op->first->first; # skip leavewrite, lineseq
1204 while (not null $op) {
1205 $op = $op->sibling; # skip nextstate
1207 $kid = $op->first->sibling; # skip pushmark
1208 push @text, "\f".$self->const_sv($kid)->PV;
1209 $kid = $kid->sibling;
1210 for (; not null $kid; $kid = $kid->sibling) {
1211 push @exprs, $self->deparse($kid, -1);
1212 $exprs[-1] =~ s/;\z//;
1214 push @text, "\f".join(", ", @exprs)."\n" if @exprs;
1217 return join("", @text) . "\f.";
1222 return $op->name eq "leave" || $op->name eq "scope"
1223 || $op->name eq "lineseq"
1224 || ($op->name eq "null" && class($op) eq "UNOP"
1225 && (is_scope($op->first) || $op->first->name eq "enter"));
1229 my $name = $_[0]->name;
1230 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
1233 sub is_miniwhile { # check for one-line loop ('foo() while $y--')
1235 return (!null($op) and null($op->sibling)
1236 and $op->name eq "null" and class($op) eq "UNOP"
1237 and (($op->first->name =~ /^(and|or)$/
1238 and $op->first->first->sibling->name eq "lineseq")
1239 or ($op->first->name eq "lineseq"
1240 and not null $op->first->first->sibling
1241 and $op->first->first->sibling->name eq "unstack")
1245 # Check if the op and its sibling are the initialization and the rest of a
1246 # for (..;..;..) { ... } loop
1249 # This OP might be almost anything, though it won't be a
1250 # nextstate. (It's the initialization, so in the canonical case it
1251 # will be an sassign.) The sibling is (old style) a lineseq whose
1252 # first child is a nextstate and whose second is a leaveloop, or
1253 # (new style) an unstack whose sibling is a leaveloop.
1254 my $lseq = $op->sibling;
1255 return 0 unless !is_state($op) and !null($lseq);
1256 if ($lseq->name eq "lineseq") {
1257 if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
1258 && (my $sib = $lseq->first->sibling)) {
1259 return (!null($sib) && $sib->name eq "leaveloop");
1261 } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) {
1262 my $sib = $lseq->sibling;
1263 return $sib && !null($sib) && $sib->name eq "leaveloop";
1270 return ($op->name eq "rv2sv" or
1271 $op->name eq "padsv" or
1272 $op->name eq "gv" or # only in array/hash constructs
1273 $op->flags & OPf_KIDS && !null($op->first)
1274 && $op->first->name eq "gvsv");
1279 my($text, $cx, $prec) = @_;
1280 if ($prec < $cx # unary ops nest just fine
1281 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
1282 or $self->{'parens'})
1285 # In a unop, let parent reuse our parens; see maybe_parens_unop
1286 $text = "\cS" . $text if $cx == 16;
1293 # same as above, but get around the 'if it looks like a function' rule
1294 sub maybe_parens_unop {
1296 my($name, $kid, $cx) = @_;
1297 if ($cx > 16 or $self->{'parens'}) {
1298 $kid = $self->deparse($kid, 1);
1299 if ($name eq "umask" && $kid =~ /^\d+$/) {
1300 $kid = sprintf("%#o", $kid);
1302 return $self->keyword($name) . "($kid)";
1304 $kid = $self->deparse($kid, 16);
1305 if ($name eq "umask" && $kid =~ /^\d+$/) {
1306 $kid = sprintf("%#o", $kid);
1308 $name = $self->keyword($name);
1309 if (substr($kid, 0, 1) eq "\cS") {
1311 return $name . substr($kid, 1);
1312 } elsif (substr($kid, 0, 1) eq "(") {
1313 # avoid looks-like-a-function trap with extra parens
1314 # ('+' can lead to ambiguities)
1315 return "$name(" . $kid . ")";
1317 return "$name $kid";
1322 sub maybe_parens_func {
1324 my($func, $text, $cx, $prec) = @_;
1325 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
1326 return "$func($text)";
1328 return "$func $text";
1333 my ($self, $name) = @_;
1334 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1335 my $seq = $self->{'curcop'} ? $self->{'curcop'}->cop_seq : 0;
1336 for my $a (@{$self->{'curcvlex'}{"o$name"}}) {
1337 my ($st, undef, $padname) = @$a;
1338 if ($st >= $seq && $padname->FLAGS & SVpad_TYPED) {
1339 return $padname->SvSTASH->NAME;
1347 my($op, $cx, $text) = @_;
1348 my $name = $op->name;
1349 my $our_intro = ($name =~ /^(?:(?:gv|rv2)[ash]v|split|refassign
1353 my $lval_intro = $name eq 'split' ? 0 : OPpLVAL_INTRO;
1354 # The @a in \(@a) isn't in ref context, but only when the
1356 my $need_parens = $self->{'in_refgen'} && $name =~ /[ah]v\z/
1357 && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
1358 if ((my $priv = $op->private) & ($lval_intro|$our_intro)) {
1360 push @our_local, "local" if $priv & $lval_intro;
1361 push @our_local, "our" if $priv & $our_intro;
1362 my $our_local = join " ", map $self->keyword($_), @our_local;
1363 if( $our_local[-1] eq 'our' ) {
1364 if ( $text !~ /^\W(\w+::)*\w+\z/
1365 and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
1367 die "Unexpected our($text)\n";
1369 $text =~ s/(\w+::)+//;
1371 if (my $type = $self->find_our_type($text)) {
1372 $our_local .= ' ' . $type;
1375 return $need_parens ? "($text)" : $text
1376 if $self->{'avoid_local'}{$$op};
1378 return "$our_local($text)";
1379 } elsif (want_scalar($op)) {
1380 return "$our_local $text";
1382 return $self->maybe_parens_func("$our_local", $text, $cx, 16);
1385 return $need_parens ? "($text)" : $text;
1391 my($op, $cx, $func, @args) = @_;
1392 if ($op->private & OPpTARGET_MY) {
1393 my $var = $self->padname($op->targ);
1394 my $val = $func->($self, $op, 7, @args);
1395 return $self->maybe_parens("$var = $val", $cx, 7);
1397 return $func->($self, $op, $cx, @args);
1404 return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
1409 my($op, $cx, $text, $padname, $forbid_parens) = @_;
1410 # The @a in \(@a) isn't in ref context, but only when the
1412 my $need_parens = !$forbid_parens && $self->{'in_refgen'}
1413 && $op->name =~ /[ah]v\z/
1414 && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
1415 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
1416 # Check $padname->FLAGS for statehood, rather than $op->private,
1417 # because enteriter ops do not carry the flag.
1419 $self->keyword($padname->FLAGS & SVpad_STATE ? "state" : "my");
1420 if ($padname->FLAGS & SVpad_TYPED) {
1421 $my .= ' ' . $padname->SvSTASH->NAME;
1424 return "$my($text)";
1425 } elsif ($forbid_parens || want_scalar($op)) {
1428 return $self->maybe_parens_func($my, $text, $cx, 16);
1431 return $need_parens ? "($text)" : $text;
1435 # The following OPs don't have functions:
1437 # pp_padany -- does not exist after parsing
1440 if ($AUTOLOAD =~ s/^.*::pp_//) {
1441 warn "unexpected OP_".
1442 ($_[1]->type == OP_CUSTOM ? "CUSTOM ($AUTOLOAD)" : uc $AUTOLOAD);
1445 die "Undefined subroutine $AUTOLOAD called";
1449 sub DESTROY {} # Do not AUTOLOAD
1451 # $root should be the op which represents the root of whatever
1452 # we're sequencing here. If it's undefined, then we don't append
1453 # any subroutine declarations to the deparsed ops, otherwise we
1454 # append appropriate declarations.
1456 my($self, $root, $cx, @ops) = @_;
1459 my $out_cop = $self->{'curcop'};
1460 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1462 if (defined $root) {
1463 $limit_seq = $out_seq;
1465 $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
1466 $limit_seq = $nseq if !defined($limit_seq)
1467 or defined($nseq) && $nseq < $limit_seq;
1469 $limit_seq = $self->{'limit_seq'}
1470 if defined($self->{'limit_seq'})
1471 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1472 local $self->{'limit_seq'} = $limit_seq;
1474 $self->walk_lineseq($root, \@ops,
1475 sub { push @exprs, $_[0]} );
1477 my $sep = $cx ? '; ' : ";\n";
1478 my $body = join($sep, grep {length} @exprs);
1480 if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
1481 $subs = join "\n", $self->seq_subs($limit_seq);
1483 return join($sep, grep {length} $body, $subs);
1487 my($real_block, $self, $op, $cx) = @_;
1491 local(@$self{qw'curstash warnings hints hinthash'})
1492 = @$self{qw'curstash warnings hints hinthash'} if $real_block;
1494 $kid = $op->first->sibling; # skip enter
1495 if (is_miniwhile($kid)) {
1496 my $top = $kid->first;
1497 my $name = $top->name;
1498 if ($name eq "and") {
1499 $name = $self->keyword("while");
1500 } elsif ($name eq "or") {
1501 $name = $self->keyword("until");
1502 } else { # no conditional -> while 1 or until 0
1503 return $self->deparse($top->first, 1) . " "
1504 . $self->keyword("while") . " 1";
1506 my $cond = $top->first;
1507 my $body = $cond->sibling->first; # skip lineseq
1508 $cond = $self->deparse($cond, 1);
1509 $body = $self->deparse($body, 1);
1510 return "$body $name $cond";
1515 for (; !null($kid); $kid = $kid->sibling) {
1518 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
1519 my $body = $self->lineseq($op, 0, @kids);
1520 return is_lexical_subs(@kids)
1522 : ($self->lex_in_scope("&do") ? "CORE::do" : "do")
1523 . " {\n\t$body\n\b}";
1525 my $lineseq = $self->lineseq($op, $cx, @kids);
1526 return (length ($lineseq) ? "$lineseq;" : "");
1530 sub pp_scope { scopeop(0, @_); }
1531 sub pp_lineseq { scopeop(0, @_); }
1532 sub pp_leave { scopeop(1, @_); }
1534 # This is a special case of scopeop and lineseq, for the case of the
1535 # main_root. The difference is that we print the output statements as
1536 # soon as we get them, for the sake of impatient users.
1540 local(@$self{qw'curstash warnings hints hinthash'})
1541 = @$self{qw'curstash warnings hints hinthash'};
1543 return if null $op->first; # Can happen, e.g., for Bytecode without -k
1544 for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
1547 $self->walk_lineseq($op, \@kids,
1548 sub { return unless length $_[0];
1549 print $self->indent($_[0] =~ s/\0\z//
1553 unless $_[1] == $#kids or $_[0] =~ /\n\z/;
1558 my ($self, $op, $kids, $callback) = @_;
1560 for (my $i = 0; $i < @kids; $i++) {
1562 if (is_state $kids[$i]) {
1563 $expr = $self->deparse($kids[$i++], 0);
1565 $callback->($expr, $i);
1569 if (is_for_loop($kids[$i])) {
1570 $callback->($expr . $self->for_loop($kids[$i], 0),
1571 $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
1574 my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2);
1575 $expr2 =~ s/^sub :(?!:)/+sub :/; # statement label otherwise
1577 $expr =~ s/;\n?\z//;
1578 $callback->($expr, $i);
1582 # The BEGIN {} is used here because otherwise this code isn't executed
1583 # when you run B::Deparse on itself.
1585 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1586 "ENV", "ARGV", "ARGVOUT", "_"); }
1592 #Carp::confess() unless ref($gv) eq "B::GV";
1593 my $cv = $gv->FLAGS & SVf_ROK ? $gv->RV : 0;
1594 my $stash = ($cv || $gv)->STASH->NAME;
1596 ? $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME
1598 ? B::safename($cv->NAME_HEK || $cv->GV->NAME)
1600 if ($stash eq 'main' && $name =~ /^::/) {
1603 elsif (($stash eq 'main'
1604 && ($globalnames{$name} || $name =~ /^[^A-Za-z_:]/))
1605 or ($stash eq $self->{'curstash'} && !$globalnames{$name}
1606 && ($stash eq 'main' || $name !~ /::/))
1611 $stash = $stash . "::";
1613 if (!$raw and $name =~ /^(\^..|{)/) {
1614 $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
1616 return $stash . $name;
1619 # Return the name to use for a stash variable.
1620 # If a lexical with the same name is in scope, or
1621 # if strictures are enabled, it may need to be
1623 sub stash_variable {
1624 my ($self, $prefix, $name, $cx) = @_;
1626 return "$prefix$name" if $name =~ /::/;
1628 unless ($prefix eq '$' || $prefix eq '@' || $prefix eq '&' || #'
1629 $prefix eq '%' || $prefix eq '$#') {
1630 return "$prefix$name";
1633 if ($name =~ /^[^\w+-]$/) {
1634 if (defined $cx && $cx == 26) {
1635 if ($prefix eq '@') {
1636 return "$prefix\{$name}";
1638 elsif ($name eq '#') { return '${#}' } # "${#}a" vs "$#a"
1640 if ($prefix eq '$#') {
1641 return "\$#{$name}";
1645 return $prefix . $self->maybe_qualify($prefix, $name);
1648 # Return just the name, without the prefix. It may be returned as a quoted
1649 # string. The second return value is a boolean indicating that.
1650 sub stash_variable_name {
1651 my($self, $prefix, $gv) = @_;
1652 my $name = $self->gv_name($gv, 1);
1653 $name = $self->maybe_qualify($prefix,$name);
1654 if ($name =~ /^(?:\S|(?!\d)[\ca-\cz]?(?:\w|::)*|\d+)\z/) {
1655 $name =~ s/^([\ca-\cz])/'^'.($1|'@')/e;
1656 $name =~ /^(\^..|{)/ and $name = "{$name}";
1657 return $name, 0; # not quoted
1660 single_delim("q", "'", $name, $self), 1;
1665 my ($self,$prefix,$name) = @_;
1666 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1667 return $name if !$prefix || $name =~ /::/;
1668 return $self->{'curstash'}.'::'. $name
1670 $name =~ /^(?!\d)\w/ # alphabetic
1671 && $v !~ /^\$[ab]\z/ # not $a or $b
1672 && !$globalnames{$name} # not a global name
1673 && $self->{hints} & $strict_bits{vars} # strict vars
1674 && !$self->lex_in_scope($v,1) # no "our"
1675 or $self->lex_in_scope($v); # conflicts with "my" variable
1680 my ($self, $name, $our) = @_;
1681 substr $name, 0, 0, = $our ? 'o' : 'm'; # our/my
1682 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1684 return 0 if !defined($self->{'curcop'});
1685 my $seq = $self->{'curcop'}->cop_seq;
1686 return 0 if !exists $self->{'curcvlex'}{$name};
1687 for my $a (@{$self->{'curcvlex'}{$name}}) {
1688 my ($st, $en) = @$a;
1689 return 1 if $seq > $st && $seq <= $en;
1694 sub populate_curcvlex {
1696 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1697 my $padlist = $cv->PADLIST;
1698 # an undef CV still in lexical chain
1699 next if class($padlist) eq "SPECIAL";
1700 my @padlist = $padlist->ARRAY;
1701 my @ns = $padlist[0]->ARRAY;
1703 for (my $i=0; $i<@ns; ++$i) {
1704 next if class($ns[$i]) eq "SPECIAL";
1705 if (class($ns[$i]) eq "PV") {
1706 # Probably that pesky lexical @_
1709 my $name = $ns[$i]->PVX;
1710 my ($seq_st, $seq_en) =
1711 ($ns[$i]->FLAGS & SVf_FAKE)
1713 : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH);
1715 push @{$self->{'curcvlex'}{
1716 ($ns[$i]->FLAGS & SVpad_OUR ? 'o' : 'm') . $name
1717 }}, [$seq_st, $seq_en, $ns[$i]];
1722 sub find_scope_st { ((find_scope(@_))[0]); }
1723 sub find_scope_en { ((find_scope(@_))[1]); }
1725 # Recurses down the tree, looking for pad variable introductions and COPs
1727 my ($self, $op, $scope_st, $scope_en) = @_;
1728 carp("Undefined op in find_scope") if !defined $op;
1729 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1732 while(my $op = shift @queue ) {
1733 for (my $o=$op->first; $$o; $o=$o->sibling) {
1734 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1735 my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW);
1736 my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH;
1737 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1738 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1739 return ($scope_st, $scope_en);
1741 elsif (is_state($o)) {
1742 my $c = $o->cop_seq;
1743 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1744 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1745 return ($scope_st, $scope_en);
1747 elsif ($o->flags & OPf_KIDS) {
1748 unshift (@queue, $o);
1753 return ($scope_st, $scope_en);
1756 # Returns a list of subs which should be inserted before the COP
1758 my ($self, $op, $out_seq) = @_;
1759 my $seq = $op->cop_seq;
1760 if ($] < 5.021006) {
1761 # If we have nephews, then our sequence number indicates
1762 # the cop_seq of the end of some sort of scope.
1763 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1764 and my $nseq = $self->find_scope_st($op->sibling) ) {
1768 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1769 return $self->seq_subs($seq);
1773 my ($self, $seq) = @_;
1775 #push @text, "# ($seq)\n";
1777 return "" if !defined $seq;
1779 while (scalar(@{$self->{'subs_todo'}})
1780 and $seq > $self->{'subs_todo'}[0][0]) {
1781 my $cv = $self->{'subs_todo'}[0][1];
1782 # Skip the OUTSIDE check for lexical subs. We may be deparsing a
1783 # cloned anon sub with lexical subs declared in it, in which case
1784 # the OUTSIDE pointer points to the anon protosub.
1785 my $lexical = !!$self->{'subs_todo'}[0][3];
1786 my $outside = !$lexical && $cv && $cv->OUTSIDE;
1787 if (!$lexical and $cv
1788 and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}})
1790 push @pending, shift @{$self->{'subs_todo'}};
1793 push @text, $self->next_todo;
1795 unshift @{$self->{'subs_todo'}}, @pending;
1799 sub _features_from_bundle {
1800 my ($hints, $hh) = @_;
1801 foreach (@{$feature::feature_bundle{@feature::hint_bundles[$hints >> $feature::hint_shift]}}) {
1802 $hh->{$feature::feature{$_}} = 1;
1807 # Notice how subs and formats are inserted between statements here;
1808 # also $[ assignments and pragmas.
1812 $self->{'curcop'} = $op;
1814 push @text, $self->cop_subs($op);
1816 # Special marker to swallow up the semicolon
1819 my $stash = $op->stashpv;
1820 if ($stash ne $self->{'curstash'}) {
1821 push @text, $self->keyword("package") . " $stash;\n";
1822 $self->{'curstash'} = $stash;
1825 if (OPpCONST_ARYBASE && $self->{'arybase'} != $op->arybase) {
1826 push @text, '$[ = '. $op->arybase .";\n";
1827 $self->{'arybase'} = $op->arybase;
1830 my $warnings = $op->warnings;
1832 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1833 $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
1835 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1836 $warning_bits = $warnings::NONE;
1838 elsif ($warnings->isa("B::SPECIAL")) {
1839 $warning_bits = undef;
1842 $warning_bits = $warnings->PV & WARN_MASK;
1845 if (defined ($warning_bits) and
1846 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1848 $self->declare_warnings($self->{'warnings'}, $warning_bits);
1849 $self->{'warnings'} = $warning_bits;
1852 my $hints = $] < 5.008009 ? $op->private : $op->hints;
1853 my $old_hints = $self->{'hints'};
1854 if ($self->{'hints'} != $hints) {
1855 push @text, $self->declare_hints($self->{'hints'}, $hints);
1856 $self->{'hints'} = $hints;
1861 $newhh = $op->hints_hash->HASH;
1864 if ($] >= 5.015006) {
1865 # feature bundle hints
1866 my $from = $old_hints & $feature::hint_mask;
1867 my $to = $ hints & $feature::hint_mask;
1869 if ($to == $feature::hint_mask) {
1870 if ($self->{'hinthash'}) {
1871 delete $self->{'hinthash'}{$_}
1872 for grep /^feature_/, keys %{$self->{'hinthash'}};
1874 else { $self->{'hinthash'} = {} }
1876 = _features_from_bundle($from, $self->{'hinthash'});
1880 $feature::hint_bundles[$to >> $feature::hint_shift];
1881 $bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12
1883 $self->keyword("no") . " feature;\n",
1884 $self->keyword("use") . " feature ':$bundle';\n";
1890 push @text, $self->declare_hinthash(
1891 $self->{'hinthash'}, $newhh,
1892 $self->{indent_size}, $self->{hints},
1894 $self->{'hinthash'} = $newhh;
1897 # This should go after of any branches that add statements, to
1898 # increase the chances that it refers to the same line it did in
1899 # the original program.
1900 if ($self->{'linenums'}) {
1901 push @text, "\f#line " . $op->line .
1902 ' "' . $op->file, qq'"\n';
1905 push @text, $op->label . ": " if $op->label;
1907 return join("", @text);
1910 sub declare_warnings {
1911 my ($self, $from, $to) = @_;
1912 if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
1913 return $self->keyword("use") . " warnings;\n";
1915 elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
1916 return $self->keyword("no") . " warnings;\n";
1918 return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n\0";
1922 my ($self, $from, $to) = @_;
1923 my $use = $to & ~$from;
1924 my $no = $from & ~$to;
1926 for my $pragma (hint_pragmas($use)) {
1927 $decls .= $self->keyword("use") . " $pragma;\n";
1929 for my $pragma (hint_pragmas($no)) {
1930 $decls .= $self->keyword("no") . " $pragma;\n";
1935 # Internal implementation hints that the core sets automatically, so don't need
1936 # (or want) to be passed back to the user
1937 my %ignored_hints = (
1948 sub declare_hinthash {
1949 my ($self, $from, $to, $indent, $hints) = @_;
1950 my $doing_features =
1951 ($hints & $feature::hint_mask) == $feature::hint_mask;
1954 my @unfeatures; # bugs?
1955 for my $key (sort keys %$to) {
1956 next if $ignored_hints{$key};
1957 my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6;
1958 next if $is_feature and not $doing_features;
1959 if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) {
1960 push(@features, $key), next if $is_feature;
1962 qq(\$^H{) . single_delim("q", "'", $key, $self) . qq(} = )
1965 ? single_delim("q", "'", $to->{$key}, $self)
1971 for my $key (sort keys %$from) {
1972 next if $ignored_hints{$key};
1973 my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6;
1974 next if $is_feature and not $doing_features;
1975 if (!exists $to->{$key}) {
1976 push(@unfeatures, $key), next if $is_feature;
1977 push @decls, qq(delete \$^H{'$key'};);
1981 if (@features || @unfeatures) {
1982 if (!%rev_feature) { %rev_feature = reverse %feature::feature }
1985 push @ret, $self->keyword("use") . " feature "
1986 . join(", ", map "'$rev_feature{$_}'", @features) . ";\n";
1989 push @ret, $self->keyword("no") . " feature "
1990 . join(", ", map "'$rev_feature{$_}'", @unfeatures)
1995 join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n\0";
2001 my (@pragmas, @strict);
2002 push @pragmas, "integer" if $bits & 0x1;
2003 for (sort keys %strict_bits) {
2004 push @strict, "'$_'" if $bits & $strict_bits{$_};
2006 if (@strict == keys %strict_bits) {
2007 push @pragmas, "strict";
2010 push @pragmas, "strict " . join ', ', @strict;
2012 push @pragmas, "bytes" if $bits & 0x8;
2016 sub pp_dbstate { pp_nextstate(@_) }
2017 sub pp_setstate { pp_nextstate(@_) }
2019 sub pp_unstack { return "" } # see also leaveloop
2021 my %feature_keywords = (
2022 # keyword => 'feature',
2027 default => 'switch',
2029 evalbytes=>'evalbytes',
2030 __SUB__ => '__SUB__',
2034 # keywords that are strong and also have a prototype
2036 my %strong_proto_keywords = map { $_ => 1 } qw(
2044 sub feature_enabled {
2045 my($self,$name) = @_;
2047 my $hints = $self->{hints} & $feature::hint_mask;
2048 if ($hints && $hints != $feature::hint_mask) {
2049 $hh = _features_from_bundle($hints);
2051 elsif ($hints) { $hh = $self->{'hinthash'} }
2052 return $hh && $hh->{"feature_$feature_keywords{$name}"}
2058 return $name if $name =~ /^CORE::/; # just in case
2059 if (exists $feature_keywords{$name}) {
2060 return "CORE::$name" if not $self->feature_enabled($name);
2062 # This sub may be called for a program that has no nextstate ops. In
2063 # that case we may have a lexical sub named no/use/sub in scope but
2064 # but $self->lex_in_scope will return false because it depends on the
2065 # current nextstate op. So we need this alternate method if there is
2067 if (!$self->{'curcop'}) {
2068 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
2069 return "CORE::$name" if exists $self->{'curcvlex'}{"m&$name"}
2070 || exists $self->{'curcvlex'}{"o&$name"};
2071 } elsif ($self->lex_in_scope("&$name")
2072 || $self->lex_in_scope("&$name", 1)) {
2073 return "CORE::$name";
2075 if ($strong_proto_keywords{$name}
2076 || ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
2077 && !defined eval{prototype "CORE::$name"})
2080 exists $self->{subs_declared}{$name}
2082 exists &{"$self->{curstash}::$name"}
2084 return "CORE::$name"
2091 my($op, $cx, $name) = @_;
2092 return $self->keyword($name);
2097 my($op, $cx, $name) = @_;
2105 sub pp_wantarray { baseop(@_, "wantarray") }
2106 sub pp_fork { baseop(@_, "fork") }
2107 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
2108 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
2109 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
2110 sub pp_tms { baseop(@_, "times") }
2111 sub pp_ghostent { baseop(@_, "gethostent") }
2112 sub pp_gnetent { baseop(@_, "getnetent") }
2113 sub pp_gprotoent { baseop(@_, "getprotoent") }
2114 sub pp_gservent { baseop(@_, "getservent") }
2115 sub pp_ehostent { baseop(@_, "endhostent") }
2116 sub pp_enetent { baseop(@_, "endnetent") }
2117 sub pp_eprotoent { baseop(@_, "endprotoent") }
2118 sub pp_eservent { baseop(@_, "endservent") }
2119 sub pp_gpwent { baseop(@_, "getpwent") }
2120 sub pp_spwent { baseop(@_, "setpwent") }
2121 sub pp_epwent { baseop(@_, "endpwent") }
2122 sub pp_ggrent { baseop(@_, "getgrent") }
2123 sub pp_sgrent { baseop(@_, "setgrent") }
2124 sub pp_egrent { baseop(@_, "endgrent") }
2125 sub pp_getlogin { baseop(@_, "getlogin") }
2127 sub POSTFIX () { 1 }
2129 # I couldn't think of a good short name, but this is the category of
2130 # symbolic unary operators with interesting precedence
2134 my($op, $cx, $name, $prec, $flags) = (@_, 0);
2135 my $kid = $op->first;
2136 $kid = $self->deparse($kid, $prec);
2137 return $self->maybe_parens(($flags & POSTFIX)
2139 # avoid confusion with filetests
2141 && $kid =~ /^[a-zA-Z](?!\w)/
2147 sub pp_preinc { pfixop(@_, "++", 23) }
2148 sub pp_predec { pfixop(@_, "--", 23) }
2149 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
2150 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
2151 sub pp_i_preinc { pfixop(@_, "++", 23) }
2152 sub pp_i_predec { pfixop(@_, "--", 23) }
2153 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
2154 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
2155 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
2157 sub pp_negate { maybe_targmy(@_, \&real_negate) }
2161 if ($op->first->name =~ /^(i_)?negate$/) {
2163 $self->pfixop($op, $cx, "-", 21.5);
2165 $self->pfixop($op, $cx, "-", 21);
2168 sub pp_i_negate { pp_negate(@_) }
2174 $self->listop($op, $cx, "not", $op->first);
2176 $self->pfixop($op, $cx, "!", 21);
2182 my($op, $cx, $name, $nollafr) = @_;
2184 if ($op->flags & OPf_KIDS) {
2187 # this deals with 'boolkeys' right now
2188 return $self->deparse($kid,$cx);
2190 my $builtinname = $name;
2191 $builtinname =~ /^CORE::/ or $builtinname = "CORE::$name";
2192 if (defined prototype($builtinname)
2193 && prototype($builtinname) =~ /^;?\*/
2194 && $kid->name eq "rv2gv") {
2199 ($kid = $self->deparse($kid, 16)) =~ s/^\cS//;
2200 return $self->maybe_parens(
2201 $self->keyword($name) . " $kid", $cx, 16
2204 return $self->maybe_parens_unop($name, $kid, $cx);
2206 return $self->maybe_parens(
2207 $self->keyword($name) . ($op->flags & OPf_SPECIAL ? "()" : ""),
2213 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
2214 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
2215 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
2216 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
2217 sub pp_defined { unop(@_, "defined") }
2218 sub pp_undef { unop(@_, "undef") }
2219 sub pp_study { unop(@_, "study") }
2220 sub pp_ref { unop(@_, "ref") }
2221 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
2223 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
2224 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
2225 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
2226 sub pp_srand { unop(@_, "srand") }
2227 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
2228 sub pp_log { maybe_targmy(@_, \&unop, "log") }
2229 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
2230 sub pp_int { maybe_targmy(@_, \&unop, "int") }
2231 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
2232 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
2233 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
2235 sub pp_length { maybe_targmy(@_, \&unop, "length") }
2236 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
2237 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
2239 sub pp_each { unop(@_, "each") }
2240 sub pp_values { unop(@_, "values") }
2241 sub pp_keys { unop(@_, "keys") }
2242 { no strict 'refs'; *{"pp_r$_"} = *{"pp_$_"} for qw< keys each values >; }
2244 # no name because its an optimisation op that has no keyword
2247 sub pp_aeach { unop(@_, "each") }
2248 sub pp_avalues { unop(@_, "values") }
2249 sub pp_akeys { unop(@_, "keys") }
2250 sub pp_pop { unop(@_, "pop") }
2251 sub pp_shift { unop(@_, "shift") }
2253 sub pp_caller { unop(@_, "caller") }
2254 sub pp_reset { unop(@_, "reset") }
2255 sub pp_exit { unop(@_, "exit") }
2256 sub pp_prototype { unop(@_, "prototype") }
2258 sub pp_close { unop(@_, "close") }
2259 sub pp_fileno { unop(@_, "fileno") }
2260 sub pp_umask { unop(@_, "umask") }
2261 sub pp_untie { unop(@_, "untie") }
2262 sub pp_tied { unop(@_, "tied") }
2263 sub pp_dbmclose { unop(@_, "dbmclose") }
2264 sub pp_getc { unop(@_, "getc") }
2265 sub pp_eof { unop(@_, "eof") }
2266 sub pp_tell { unop(@_, "tell") }
2267 sub pp_getsockname { unop(@_, "getsockname") }
2268 sub pp_getpeername { unop(@_, "getpeername") }
2270 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
2271 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
2272 sub pp_readlink { unop(@_, "readlink") }
2273 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
2274 sub pp_readdir { unop(@_, "readdir") }
2275 sub pp_telldir { unop(@_, "telldir") }
2276 sub pp_rewinddir { unop(@_, "rewinddir") }
2277 sub pp_closedir { unop(@_, "closedir") }
2278 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
2279 sub pp_localtime { unop(@_, "localtime") }
2280 sub pp_gmtime { unop(@_, "gmtime") }
2281 sub pp_alarm { unop(@_, "alarm") }
2282 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
2285 my $code = unop(@_, "do", 1); # llafr does not apply
2286 if ($code =~ s/^((?:CORE::)?do) \{/$1({/) { $code .= ')' }
2292 $_[1]->private & OPpEVAL_BYTES ? $_[0]->keyword('evalbytes') : "eval"
2296 sub pp_ghbyname { unop(@_, "gethostbyname") }
2297 sub pp_gnbyname { unop(@_, "getnetbyname") }
2298 sub pp_gpbyname { unop(@_, "getprotobyname") }
2299 sub pp_shostent { unop(@_, "sethostent") }
2300 sub pp_snetent { unop(@_, "setnetent") }
2301 sub pp_sprotoent { unop(@_, "setprotoent") }
2302 sub pp_sservent { unop(@_, "setservent") }
2303 sub pp_gpwnam { unop(@_, "getpwnam") }
2304 sub pp_gpwuid { unop(@_, "getpwuid") }
2305 sub pp_ggrnam { unop(@_, "getgrnam") }
2306 sub pp_ggrgid { unop(@_, "getgrgid") }
2308 sub pp_lock { unop(@_, "lock") }
2310 sub pp_continue { unop(@_, "continue"); }
2311 sub pp_break { unop(@_, "break"); }
2315 my($op, $cx, $givwhen) = @_;
2317 my $enterop = $op->first;
2319 if ($enterop->flags & OPf_SPECIAL) {
2320 $head = $self->keyword("default");
2321 $block = $self->deparse($enterop->first, 0);
2324 my $cond = $enterop->first;
2325 my $cond_str = $self->deparse($cond, 1);
2326 $head = "$givwhen ($cond_str)";
2327 $block = $self->deparse($cond->sibling, 0);
2335 sub pp_leavegiven { givwhen(@_, $_[0]->keyword("given")); }
2336 sub pp_leavewhen { givwhen(@_, $_[0]->keyword("when")); }
2342 my $name = $self->keyword("exists");
2343 if ($op->private & OPpEXISTS_SUB) {
2344 # Checking for the existence of a subroutine
2345 return $self->maybe_parens_func($name,
2346 $self->pp_rv2cv($op->first, 16), $cx, 16);
2348 if ($op->flags & OPf_SPECIAL) {
2349 # Array element, not hash element
2350 return $self->maybe_parens_func($name,
2351 $self->pp_aelem($op->first, 16), $cx, 16);
2353 return $self->maybe_parens_func($name, $self->pp_helem($op->first, 16),
2361 my $name = $self->keyword("delete");
2362 if ($op->private & OPpSLICE) {
2363 if ($op->flags & OPf_SPECIAL) {
2364 # Deleting from an array, not a hash
2365 return $self->maybe_parens_func($name,
2366 $self->pp_aslice($op->first, 16),
2369 return $self->maybe_parens_func($name,
2370 $self->pp_hslice($op->first, 16),
2373 if ($op->flags & OPf_SPECIAL) {
2374 # Deleting from an array, not a hash
2375 return $self->maybe_parens_func($name,
2376 $self->pp_aelem($op->first, 16),
2379 return $self->maybe_parens_func($name,
2380 $self->pp_helem($op->first, 16),
2388 my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
2389 if (class($op) eq "UNOP" and $op->first->name eq "const"
2390 and $op->first->private & OPpCONST_BARE)
2392 my $name = $self->const_sv($op->first)->PV;
2395 return $self->maybe_parens("$opname $name", $cx, 16);
2399 $op->first->name eq 'const'
2400 && $op->first->private & OPpCONST_NOVER
2403 1, # llafr does not apply
2411 my $kid = $op->first;
2412 if (not null $kid->sibling) {
2413 # XXX Was a here-doc
2414 return $self->dquote($op);
2416 $self->unop(@_, "scalar");
2423 return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
2426 sub anon_hash_or_list {
2430 my($pre, $post) = @{{"anonlist" => ["[","]"],
2431 "anonhash" => ["{","}"]}->{$op->name}};
2433 $op = $op->first->sibling; # skip pushmark
2434 for (; !null($op); $op = $op->sibling) {
2435 $expr = $self->deparse($op, 6);
2438 if ($pre eq "{" and $cx < 1) {
2439 # Disambiguate that it's not a block
2442 return $pre . join(", ", @exprs) . $post;
2448 if ($op->flags & OPf_SPECIAL) {
2449 return $self->anon_hash_or_list($op, $cx);
2451 warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL";
2455 *pp_anonhash = \&pp_anonlist;
2460 my $kid = $op->first;
2461 if ($kid->name eq "null") {
2462 my $anoncode = $kid = $kid->first;
2463 if ($anoncode->name eq "anoncode"
2464 or !null($anoncode = $kid->sibling) and
2465 $anoncode->name eq "anoncode") {
2466 return $self->e_anoncode({ code => $self->padval($anoncode->targ) });
2467 } elsif ($kid->name eq "pushmark") {
2468 my $sib_name = $kid->sibling->name;
2469 if ($sib_name eq 'entersub') {
2470 my $text = $self->deparse($kid->sibling, 1);
2471 # Always show parens for \(&func()), but only with -p otherwise
2472 $text = "($text)" if $self->{'parens'}
2473 or $kid->sibling->private & OPpENTERSUB_AMPER;
2478 local $self->{'in_refgen'} = 1;
2479 $self->pfixop($op, $cx, "\\", 20);
2483 my ($self, $info) = @_;
2484 my $text = $self->deparse_sub($info->{code});
2485 return $self->keyword("sub") . " $text";
2488 sub pp_srefgen { pp_refgen(@_) }
2493 my $kid = $op->first;
2494 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
2495 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
2496 return $self->unop($op, $cx, "readline");
2502 return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
2505 # Unary operators that can occur as pseudo-listops inside double quotes
2508 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
2510 if ($op->flags & OPf_KIDS) {
2512 # If there's more than one kid, the first is an ex-pushmark.
2513 $kid = $kid->sibling if not null $kid->sibling;
2514 return $self->maybe_parens_unop($name, $kid, $cx);
2516 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
2520 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
2521 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
2522 sub pp_uc { dq_unop(@_, "uc") }
2523 sub pp_lc { dq_unop(@_, "lc") }
2524 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
2525 sub pp_fc { dq_unop(@_, "fc") }
2529 my ($op, $cx, $name) = @_;
2530 if (class($op) eq "PVOP") {
2531 $name .= " " . $op->pv;
2532 } elsif (class($op) eq "OP") {
2534 } elsif (class($op) eq "UNOP") {
2535 (my $kid = $self->deparse($op->first, 7)) =~ s/^\cS//;
2538 return $self->maybe_parens($name, $cx, 7);
2541 sub pp_last { loopex(@_, "last") }
2542 sub pp_next { loopex(@_, "next") }
2543 sub pp_redo { loopex(@_, "redo") }
2544 sub pp_goto { loopex(@_, "goto") }
2545 sub pp_dump { loopex(@_, "CORE::dump") }
2549 my($op, $cx, $name) = @_;
2550 if (class($op) eq "UNOP") {
2551 # Genuine '-X' filetests are exempt from the LLAFR, but not
2553 if ($name =~ /^-/) {
2554 (my $kid = $self->deparse($op->first, 16)) =~ s/^\cS//;
2555 return $self->maybe_parens("$name $kid", $cx, 16);
2557 return $self->maybe_parens_unop($name, $op->first, $cx);
2558 } elsif (class($op) =~ /^(SV|PAD)OP$/) {
2559 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
2560 } else { # I don't think baseop filetests ever survive ck_ftst, but...
2565 sub pp_lstat { ftst(@_, "lstat") }
2566 sub pp_stat { ftst(@_, "stat") }
2567 sub pp_ftrread { ftst(@_, "-R") }
2568 sub pp_ftrwrite { ftst(@_, "-W") }
2569 sub pp_ftrexec { ftst(@_, "-X") }
2570 sub pp_fteread { ftst(@_, "-r") }
2571 sub pp_ftewrite { ftst(@_, "-w") }
2572 sub pp_fteexec { ftst(@_, "-x") }
2573 sub pp_ftis { ftst(@_, "-e") }
2574 sub pp_fteowned { ftst(@_, "-O") }
2575 sub pp_ftrowned { ftst(@_, "-o") }
2576 sub pp_ftzero { ftst(@_, "-z") }
2577 sub pp_ftsize { ftst(@_, "-s") }
2578 sub pp_ftmtime { ftst(@_, "-M") }
2579 sub pp_ftatime { ftst(@_, "-A") }
2580 sub pp_ftctime { ftst(@_, "-C") }
2581 sub pp_ftsock { ftst(@_, "-S") }
2582 sub pp_ftchr { ftst(@_, "-c") }
2583 sub pp_ftblk { ftst(@_, "-b") }
2584 sub pp_ftfile { ftst(@_, "-f") }
2585 sub pp_ftdir { ftst(@_, "-d") }
2586 sub pp_ftpipe { ftst(@_, "-p") }
2587 sub pp_ftlink { ftst(@_, "-l") }
2588 sub pp_ftsuid { ftst(@_, "-u") }
2589 sub pp_ftsgid { ftst(@_, "-g") }
2590 sub pp_ftsvtx { ftst(@_, "-k") }
2591 sub pp_fttty { ftst(@_, "-t") }
2592 sub pp_fttext { ftst(@_, "-T") }
2593 sub pp_ftbinary { ftst(@_, "-B") }
2595 sub SWAP_CHILDREN () { 1 }
2596 sub ASSIGN () { 2 } # has OP= variant
2597 sub LIST_CONTEXT () { 4 } # Assignment is in list context
2603 my $name = $op->name;
2604 if ($name eq "concat" and $op->first->name eq "concat") {
2605 # avoid spurious '=' -- see comment in pp_concat
2608 if ($name eq "null" and class($op) eq "UNOP"
2609 and $op->first->name =~ /^(and|x?or)$/
2610 and null $op->first->sibling)
2612 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
2613 # with a null that's used as the common end point of the two
2614 # flows of control. For precedence purposes, ignore it.
2615 # (COND_EXPRs have these too, but we don't bother with
2616 # their associativity).
2617 return assoc_class($op->first);
2619 return $name . ($op->flags & OPf_STACKED ? "=" : "");
2622 # Left associative operators, like '+', for which
2623 # $a + $b + $c is equivalent to ($a + $b) + $c
2626 %left = ('multiply' => 19, 'i_multiply' => 19,
2627 'divide' => 19, 'i_divide' => 19,
2628 'modulo' => 19, 'i_modulo' => 19,
2630 'add' => 18, 'i_add' => 18,
2631 'subtract' => 18, 'i_subtract' => 18,
2633 'left_shift' => 17, 'right_shift' => 17,
2635 'bit_or' => 12, 'bit_xor' => 12,
2637 'or' => 2, 'xor' => 2,
2641 sub deparse_binop_left {
2643 my($op, $left, $prec) = @_;
2644 if ($left{assoc_class($op)} && $left{assoc_class($left)}
2645 and $left{assoc_class($op)} == $left{assoc_class($left)})
2647 return $self->deparse($left, $prec - .00001);
2649 return $self->deparse($left, $prec);
2653 # Right associative operators, like '=', for which
2654 # $a = $b = $c is equivalent to $a = ($b = $c)
2657 %right = ('pow' => 22,
2658 'sassign=' => 7, 'aassign=' => 7,
2659 'multiply=' => 7, 'i_multiply=' => 7,
2660 'divide=' => 7, 'i_divide=' => 7,
2661 'modulo=' => 7, 'i_modulo=' => 7,
2662 'repeat=' => 7, 'refassign' => 7, 'refassign=' => 7,
2663 'add=' => 7, 'i_add=' => 7,
2664 'subtract=' => 7, 'i_subtract=' => 7,
2666 'left_shift=' => 7, 'right_shift=' => 7,
2668 'bit_or=' => 7, 'bit_xor=' => 7,
2674 sub deparse_binop_right {
2676 my($op, $right, $prec) = @_;
2677 if ($right{assoc_class($op)} && $right{assoc_class($right)}
2678 and $right{assoc_class($op)} == $right{assoc_class($right)})
2680 return $self->deparse($right, $prec - .00001);
2682 return $self->deparse($right, $prec);
2688 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
2689 my $left = $op->first;
2690 my $right = $op->last;
2692 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
2696 if ($flags & SWAP_CHILDREN) {
2697 ($left, $right) = ($right, $left);
2700 $left = $self->deparse_binop_left($op, $left, $prec);
2701 $left = "($left)" if $flags & LIST_CONTEXT
2702 and $left !~ /^(my|our|local|)[\@\(]/
2704 # Parenthesize if the left argument is a
2706 my $left = $leftop->first->sibling;
2707 $left->name eq 'repeat'
2708 && null($left->sibling);
2710 $right = $self->deparse_binop_right($op, $right, $prec);
2711 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
2714 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2715 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2716 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
2717 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2718 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2719 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2720 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2721 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
2722 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2723 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2724 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
2726 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
2727 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
2728 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
2729 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
2730 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
2732 sub pp_eq { binop(@_, "==", 14) }
2733 sub pp_ne { binop(@_, "!=", 14) }
2734 sub pp_lt { binop(@_, "<", 15) }
2735 sub pp_gt { binop(@_, ">", 15) }
2736 sub pp_ge { binop(@_, ">=", 15) }
2737 sub pp_le { binop(@_, "<=", 15) }
2738 sub pp_ncmp { binop(@_, "<=>", 14) }
2739 sub pp_i_eq { binop(@_, "==", 14) }
2740 sub pp_i_ne { binop(@_, "!=", 14) }
2741 sub pp_i_lt { binop(@_, "<", 15) }
2742 sub pp_i_gt { binop(@_, ">", 15) }
2743 sub pp_i_ge { binop(@_, ">=", 15) }
2744 sub pp_i_le { binop(@_, "<=", 15) }
2745 sub pp_i_ncmp { binop(@_, "<=>", 14) }
2747 sub pp_seq { binop(@_, "eq", 14) }
2748 sub pp_sne { binop(@_, "ne", 14) }
2749 sub pp_slt { binop(@_, "lt", 15) }
2750 sub pp_sgt { binop(@_, "gt", 15) }
2751 sub pp_sge { binop(@_, "ge", 15) }
2752 sub pp_sle { binop(@_, "le", 15) }
2753 sub pp_scmp { binop(@_, "cmp", 14) }
2755 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
2756 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
2759 my ($self, $op, $cx) = @_;
2760 if ($op->flags & OPf_SPECIAL) {
2761 return $self->deparse($op->last, $cx);
2764 binop(@_, "~~", 14);
2768 # '.' is special because concats-of-concats are optimized to save copying
2769 # by making all but the first concat stacked. The effect is as if the
2770 # programmer had written '($a . $b) .= $c', except legal.
2771 sub pp_concat { maybe_targmy(@_, \&real_concat) }
2775 my $left = $op->first;
2776 my $right = $op->last;
2779 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
2783 $left = $self->deparse_binop_left($op, $left, $prec);
2784 $right = $self->deparse_binop_right($op, $right, $prec);
2785 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
2788 sub pp_repeat { maybe_targmy(@_, \&repeat) }
2790 # 'x' is weird when the left arg is a list
2794 my $left = $op->first;
2795 my $right = $op->last;
2798 if ($op->flags & OPf_STACKED) {
2802 if (null($right)) { # list repeat; count is inside left-side ex-list
2803 # in 5.21.5 and earlier
2804 my $kid = $left->first->sibling; # skip pushmark
2806 for (; !null($kid->sibling); $kid = $kid->sibling) {
2807 push @exprs, $self->deparse($kid, 6);
2810 $left = "(" . join(", ", @exprs). ")";
2812 my $dolist = $op->private & OPpREPEAT_DOLIST;
2813 $left = $self->deparse_binop_left($op, $left, $dolist ? 1 : $prec);
2818 $right = $self->deparse_binop_right($op, $right, $prec);
2819 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
2824 my ($op, $cx, $type) = @_;
2825 my $left = $op->first;
2826 my $right = $left->sibling;
2827 $left = $self->deparse($left, 9);
2828 $right = $self->deparse($right, 9);
2829 return $self->maybe_parens("$left $type $right", $cx, 9);
2835 my $flip = $op->first;
2836 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
2837 return $self->range($flip->first, $cx, $type);
2840 # one-line while/until is handled in pp_leave
2844 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
2845 my $left = $op->first;
2846 my $right = $op->first->sibling;
2847 $blockname &&= $self->keyword($blockname);
2848 if ($cx < 1 and is_scope($right) and $blockname
2849 and $self->{'expand'} < 7)
2851 $left = $self->deparse($left, 1);
2852 $right = $self->deparse($right, 0);
2853 return "$blockname ($left) {\n\t$right\n\b}\cK";
2854 } elsif ($cx < 1 and $blockname and not $self->{'parens'}
2855 and $self->{'expand'} < 7) { # $b if $a
2856 $right = $self->deparse($right, 1);
2857 $left = $self->deparse($left, 1);
2858 return "$right $blockname $left";
2859 } elsif ($cx > $lowprec and $highop) { # $a && $b
2860 $left = $self->deparse_binop_left($op, $left, $highprec);
2861 $right = $self->deparse_binop_right($op, $right, $highprec);
2862 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
2863 } else { # $a and $b
2864 $left = $self->deparse_binop_left($op, $left, $lowprec);
2865 $right = $self->deparse_binop_right($op, $right, $lowprec);
2866 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
2870 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
2871 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
2872 sub pp_dor { logop(@_, "//", 10) }
2874 # xor is syntactically a logop, but it's really a binop (contrary to
2875 # old versions of opcode.pl). Syntax is what matters here.
2876 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
2880 my ($op, $cx, $opname) = @_;
2881 my $left = $op->first;
2882 my $right = $op->first->sibling->first; # skip sassign
2883 $left = $self->deparse($left, 7);
2884 $right = $self->deparse($right, 7);
2885 return $self->maybe_parens("$left $opname $right", $cx, 7);
2888 sub pp_andassign { logassignop(@_, "&&=") }
2889 sub pp_orassign { logassignop(@_, "||=") }
2890 sub pp_dorassign { logassignop(@_, "//=") }
2892 sub rv2gv_or_string {
2894 if ($op->name eq "gv") { # could be open("open") or open("###")
2896 $self->stash_variable_name("", $self->gv_or_padgv($op));
2897 $quoted ? $name : "*$name";
2900 $self->deparse($op, 6);
2906 my($op, $cx, $name, $kid, $nollafr) = @_;
2908 my $parens = ($cx >= 5) || $self->{'parens'};
2909 $kid ||= $op->first->sibling;
2910 # If there are no arguments, add final parentheses (or parenthesize the
2911 # whole thing if the llafr does not apply) to account for cases like
2912 # (return)+1 or setpgrp()+1. When the llafr does not apply, we use a
2913 # precedence of 6 (< comma), as "return, 1" does not need parentheses.
2916 ? $self->maybe_parens($self->keyword($name), $cx, 7)
2917 : $self->keyword($name) . '()' x (7 < $cx);
2920 my $fullname = $self->keyword($name);
2921 my $proto = prototype("CORE::$name");
2923 ( (defined $proto && $proto =~ /^;?\*/)
2924 || $name eq 'select' # select(F) doesn't have a proto
2926 && $kid->name eq "rv2gv"
2927 && !($kid->private & OPpLVAL_INTRO)
2929 $first = $self->rv2gv_or_string($kid->first);
2932 $first = $self->deparse($kid, 6);
2934 if ($name eq "chmod" && $first =~ /^\d+$/) {
2935 $first = sprintf("%#o", $first);
2938 if not $parens and not $nollafr and substr($first, 0, 1) eq "(";
2939 push @exprs, $first;
2940 $kid = $kid->sibling;
2941 if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv"
2942 && !($kid->private & OPpLVAL_INTRO)) {
2943 push @exprs, $first = $self->rv2gv_or_string($kid->first);
2944 $kid = $kid->sibling;
2946 for (; !null($kid); $kid = $kid->sibling) {
2947 push @exprs, $self->deparse($kid, 6);
2949 if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) {
2950 return "$exprs[0] = $fullname"
2951 . ($parens ? "($exprs[0])" : " $exprs[0]");
2953 if ($name =~ /^(system|exec)$/
2954 && ($op->flags & OPf_STACKED)
2957 # handle the "system prog a1,a2,.." form
2958 my $prog = shift @exprs;
2959 $exprs[0] = "$prog $exprs[0]";
2962 if ($parens && $nollafr) {
2963 return "($fullname " . join(", ", @exprs) . ")";
2965 return "$fullname(" . join(", ", @exprs) . ")";
2967 return "$fullname " . join(", ", @exprs);
2971 sub pp_bless { listop(@_, "bless") }
2972 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
2974 my ($self,$op,$cx) = @_;
2975 if ($op->private & OPpSUBSTR_REPL_FIRST) {
2977 listop($self, $op, 7, "substr", $op->first->sibling->sibling)
2979 . $self->deparse($op->first->sibling, 7);
2981 maybe_local(@_, listop(@_, "substr"))
2983 sub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) }
2984 sub pp_index { maybe_targmy(@_, \&listop, "index") }
2985 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
2986 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
2987 sub pp_formline { listop(@_, "formline") } # see also deparse_format
2988 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
2989 sub pp_unpack { listop(@_, "unpack") }
2990 sub pp_pack { listop(@_, "pack") }
2991 sub pp_join { maybe_targmy(@_, \&listop, "join") }
2992 sub pp_splice { listop(@_, "splice") }
2993 sub pp_push { maybe_targmy(@_, \&listop, "push") }
2994 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
2995 sub pp_reverse { listop(@_, "reverse") }
2996 sub pp_warn { listop(@_, "warn") }
2997 sub pp_die { listop(@_, "die") }
2998 sub pp_return { listop(@_, "return", undef, 1) } # llafr does not apply
2999 sub pp_open { listop(@_, "open") }
3000 sub pp_pipe_op { listop(@_, "pipe") }
3001 sub pp_tie { listop(@_, "tie") }
3002 sub pp_binmode { listop(@_, "binmode") }
3003 sub pp_dbmopen { listop(@_, "dbmopen") }
3004 sub pp_sselect { listop(@_, "select") }
3005 sub pp_select { listop(@_, "select") }
3006 sub pp_read { listop(@_, "read") }
3007 sub pp_sysopen { listop(@_, "sysopen") }
3008 sub pp_sysseek { listop(@_, "sysseek") }
3009 sub pp_sysread { listop(@_, "sysread") }
3010 sub pp_syswrite { listop(@_, "syswrite") }
3011 sub pp_send { listop(@_, "send") }
3012 sub pp_recv { listop(@_, "recv") }
3013 sub pp_seek { listop(@_, "seek") }
3014 sub pp_fcntl { listop(@_, "fcntl") }
3015 sub pp_ioctl { listop(@_, "ioctl") }
3016 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
3017 sub pp_socket { listop(@_, "socket") }
3018 sub pp_sockpair { listop(@_, "socketpair") }
3019 sub pp_bind { listop(@_, "bind") }
3020 sub pp_connect { listop(@_, "connect") }
3021 sub pp_listen { listop(@_, "listen") }
3022 sub pp_accept { listop(@_, "accept") }
3023 sub pp_shutdown { listop(@_, "shutdown") }
3024 sub pp_gsockopt { listop(@_, "getsockopt") }
3025 sub pp_ssockopt { listop(@_, "setsockopt") }
3026 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
3027 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
3028 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
3029 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
3030 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
3031 sub pp_link { maybe_targmy(@_, \&listop, "link") }
3032 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
3033 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
3034 sub pp_open_dir { listop(@_, "opendir") }
3035 sub pp_seekdir { listop(@_, "seekdir") }
3036 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
3037 sub pp_system { maybe_targmy(@_, \&listop, "system") }
3038 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
3039 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
3040 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
3041 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
3042 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
3043 sub pp_shmget { listop(@_, "shmget") }
3044 sub pp_shmctl { listop(@_, "shmctl") }
3045 sub pp_shmread { listop(@_, "shmread") }
3046 sub pp_shmwrite { listop(@_, "shmwrite") }
3047 sub pp_msgget { listop(@_, "msgget") }
3048 sub pp_msgctl { listop(@_, "msgctl") }
3049 sub pp_msgsnd { listop(@_, "msgsnd") }
3050 sub pp_msgrcv { listop(@_, "msgrcv") }
3051 sub pp_semget { listop(@_, "semget") }
3052 sub pp_semctl { listop(@_, "semctl") }
3053 sub pp_semop { listop(@_, "semop") }
3054 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
3055 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
3056 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
3057 sub pp_gsbyname { listop(@_, "getservbyname") }
3058 sub pp_gsbyport { listop(@_, "getservbyport") }
3059 sub pp_syscall { listop(@_, "syscall") }
3064 my $kid = $op->first->sibling; # skip pushmark
3066 $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
3068 if ($keyword =~ /^CORE::/
3069 or $kid->name ne 'const'
3070 or ($text = $self->dq($kid))
3071 =~ /^\$?(\w|::|\`)+$/ # could look like a readline
3072 or $text =~ /[<>]/) {
3073 $text = $self->deparse($kid);
3074 return $cx >= 5 || $self->{'parens'}
3078 return '<' . $text . '>';
3082 # Truncate is special because OPf_SPECIAL makes a bareword first arg
3083 # be a filehandle. This could probably be better fixed in the core
3084 # by moving the GV lookup into ck_truc.
3090 my $parens = ($cx >= 5) || $self->{'parens'};
3091 my $kid = $op->first->sibling;
3093 if ($op->flags & OPf_SPECIAL) {
3094 # $kid is an OP_CONST
3095 $fh = $self->const_sv($kid)->PV;
3097 $fh = $self->deparse($kid, 6);
3098 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
3100 my $len = $self->deparse($kid->sibling, 6);
3101 my $name = $self->keyword('truncate');
3103 return "$name($fh, $len)";
3105 return "$name $fh, $len";
3111 my($op, $cx, $name) = @_;
3113 my $firstkid = my $kid = $op->first->sibling;
3115 if ($op->flags & OPf_STACKED) {
3117 $indir = $indir->first; # skip rv2gv
3118 if (is_scope($indir)) {
3119 $indir = "{" . $self->deparse($indir, 0) . "}";
3120 $indir = "{;}" if $indir eq "{}";
3121 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
3122 $indir = $self->const_sv($indir)->PV;
3124 $indir = $self->deparse($indir, 24);
3126 $indir = $indir . " ";
3127 $kid = $kid->sibling;
3129 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
3130 $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
3133 elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
3134 $indir = '{$b cmp $a} ';
3136 for (; !null($kid); $kid = $kid->sibling) {
3137 $expr = $self->deparse($kid, !$indir && $kid == $firstkid && $name eq "sort" && $firstkid->name eq "entersub" ? 16 : 6);
3141 if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
3142 $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort');
3144 else { $name2 = $self->keyword($name) }
3145 if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
3146 return "$exprs[0] = $name2 $indir $exprs[0]";
3149 my $args = $indir . join(", ", @exprs);
3150 if ($indir ne "" && $name eq "sort") {
3151 # We don't want to say "sort(f 1, 2, 3)", since perl -w will
3152 # give bareword warnings in that case. Therefore if context
3153 # requires, we'll put parens around the outside "(sort f 1, 2,
3154 # 3)". Unfortunately, we'll currently think the parens are
3155 # necessary more often that they really are, because we don't
3156 # distinguish which side of an assignment we're on.
3158 return "($name2 $args)";
3160 return "$name2 $args";
3163 !$indir && $name eq "sort"
3164 && !null($op->first->sibling)
3165 && $op->first->sibling->name eq 'entersub'
3167 # We cannot say sort foo(bar), as foo will be interpreted as a
3168 # comparison routine. We have to say sort(...) in that case.
3169 return "$name2($args)";
3171 return $self->maybe_parens_func($name2, $args, $cx, 5);
3176 sub pp_prtf { indirop(@_, "printf") }
3177 sub pp_print { indirop(@_, "print") }
3178 sub pp_say { indirop(@_, "say") }
3179 sub pp_sort { indirop(@_, "sort") }
3183 my($op, $cx, $name) = @_;
3185 my $kid = $op->first; # this is the (map|grep)start
3186 $kid = $kid->first->sibling; # skip a pushmark
3187 my $code = $kid->first; # skip a null
3188 if (is_scope $code) {
3189 $code = "{" . $self->deparse($code, 0) . "} ";
3191 $code = $self->deparse($code, 24);
3192 $code .= ", " if !null($kid->sibling);
3194 $kid = $kid->sibling;
3195 for (; !null($kid); $kid = $kid->sibling) {
3196 $expr = $self->deparse($kid, 6);
3197 push @exprs, $expr if defined $expr;
3199 return $self->maybe_parens_func($self->keyword($name),
3200 $code . join(", ", @exprs), $cx, 5);
3203 sub pp_mapwhile { mapop(@_, "map") }
3204 sub pp_grepwhile { mapop(@_, "grep") }
3205 sub pp_mapstart { baseop(@_, "map") }
3206 sub pp_grepstart { baseop(@_, "grep") }
3211 eval { require B::Op_private }
3212 ? @{$B::Op_private::ops_using{OPpLVAL_INTRO}}
3213 : qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice
3214 hslice delete padsv padav padhv enteriter entersub padrange
3215 pushmark cond_expr refassign list)
3217 delete @uses_intro{qw( lvref lvrefslice lvavref )};
3224 my $kid = $op->first->sibling; # skip pushmark
3225 return '' if class($kid) eq 'NULL';
3227 my $local = "either"; # could be local(...), my(...), state(...) or our(...)
3229 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
3230 my $lopname = $lop->name;
3231 my $loppriv = $lop->private;
3233 if ($lopname =~ /^pad[ash]v$/ && $loppriv & OPpLVAL_INTRO) {
3234 if ($loppriv & OPpPAD_STATE) { # state()
3235 ($local = "", last) if $local !~ /^(?:either|state)$/;
3238 ($local = "", last) if $local !~ /^(?:either|my)$/;
3241 my $padname = $self->padname_sv($lop->targ);
3242 if ($padname->FLAGS & SVpad_TYPED) {
3243 $newtype = $padname->SvSTASH->NAME;
3245 } elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/
3246 && $loppriv & OPpOUR_INTRO
3247 or $lopname eq "null" && $lop->first->name eq "gvsv"
3248 && $lop->first->private & OPpOUR_INTRO) { # our()
3249 my $newlocal = "local " x !!($loppriv & OPpLVAL_INTRO) . "our";
3251 if $local ne 'either' && $local ne $newlocal;
3253 my $funny = !$1 || $1 eq 's' ? '$' : $1 eq 'a' ? '@' : '%';
3254 if (my $t = $self->find_our_type(
3255 $funny . $self->gv_or_padgv($lop->first)->NAME
3259 } elsif ($lopname ne 'undef'
3260 and !($loppriv & OPpLVAL_INTRO)
3261 || !exists $uses_intro{$lopname eq 'null'
3262 ? substr B::ppname($lop->targ), 3
3265 $local = ""; # or not
3267 } elsif ($lopname ne "undef")
3270 ($local = "", last) if $local !~ /^(?:either|local)$/;
3273 if (defined $type && defined $newtype && $newtype ne $type) {
3279 $local = "" if $local eq "either"; # no point if it's all undefs
3280 $local &&= join ' ', map $self->keyword($_), split / /, $local;
3281 $local .= " $type " if $local && length $type;
3282 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
3283 for (; !null($kid); $kid = $kid->sibling) {
3285 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
3290 $self->{'avoid_local'}{$$lop}++;
3291 $expr = $self->deparse($kid, 6);
3292 delete $self->{'avoid_local'}{$$lop};
3294 $expr = $self->deparse($kid, 6);
3299 return "$local(" . join(", ", @exprs) . ")";
3301 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
3305 sub is_ifelse_cont {
3307 return ($op->name eq "null" and class($op) eq "UNOP"
3308 and $op->first->name =~ /^(and|cond_expr)$/
3309 and is_scope($op->first->first->sibling));
3315 my $cond = $op->first;
3316 my $true = $cond->sibling;
3317 my $false = $true->sibling;
3318 my $cuddle = $self->{'cuddle'};
3319 unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
3320 (is_scope($false) || is_ifelse_cont($false))
3321 and $self->{'expand'} < 7) {
3322 $cond = $self->deparse($cond, 8);
3323 $true = $self->deparse($true, 6);
3324 $false = $self->deparse($false, 8);
3325 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
3328 $cond = $self->deparse($cond, 1);
3329 $true = $self->deparse($true, 0);
3330 my $head = $self->keyword("if") . " ($cond) {\n\t$true\n\b}";
3333 while (!null($false) and is_ifelse_cont($false)) {
3334 my $newop = $false->first;
3335 my $newcond = $newop->first;
3336 my $newtrue = $newcond->sibling;
3337 $false = $newtrue->sibling; # last in chain is OP_AND => no else
3338 if ($newcond->name eq "lineseq")
3340 # lineseq to ensure correct line numbers in elsif()
3341 # Bug #37302 fixed by change #33710.
3342 $newcond = $newcond->first->sibling;
3344 $newcond = $self->deparse($newcond, 1);
3345 $newtrue = $self->deparse($newtrue, 0);
3346 $elsif ||= $self->keyword("elsif");
3347 push @elsifs, "$elsif ($newcond) {\n\t$newtrue\n\b}";
3349 if (!null($false)) {
3350 $false = $cuddle . $self->keyword("else") . " {\n\t" .
3351 $self->deparse($false, 0) . "\n\b}\cK";
3355 return $head . join($cuddle, "", @elsifs) . $false;
3359 my ($self, $op, $cx) = @_;
3360 my $cond = $op->first;
3361 my $true = $cond->sibling;
3363 my $ret = $self->deparse($true, $cx);
3364 $ret =~ s/^(\(?)\$/$1 . $self->keyword("state") . ' $'/e;
3370 my($op, $cx, $init) = @_;
3371 my $enter = $op->first;
3372 my $kid = $enter->sibling;
3373 local(@$self{qw'curstash warnings hints hinthash'})
3374 = @$self{qw'curstash warnings hints hinthash'};
3380 if ($kid->name eq "lineseq") { # bare or infinite loop
3381 if ($kid->last->name eq "unstack") { # infinite
3382 $head = "while (1) "; # Can't use for(;;) if there's a continue
3388 } elsif ($enter->name eq "enteriter") { # foreach
3389 my $ary = $enter->first->sibling; # first was pushmark
3390 my $var = $ary->sibling;
3391 if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
3392 # "reverse" was optimised away
3393 $ary = listop($self, $ary->first->sibling, 1, 'reverse');
3394 } elsif ($enter->flags & OPf_STACKED
3395 and not null $ary->first->sibling->sibling)
3397 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
3398 $self->deparse($ary->first->sibling->sibling, 9);
3400 $ary = $self->deparse($ary, 1);
3403 $var = $self->pp_padsv($enter, 1, 1);
3404 } elsif ($var->name eq "rv2gv") {
3405 $var = $self->pp_rv2sv($var, 1);
3406 if ($enter->private & OPpOUR_INTRO) {
3407 # our declarations don't have package names
3408 $var =~ s/^(.).*::/$1/;
3411 } elsif ($var->name eq "gv") {
3412 $var = "\$" . $self->deparse($var, 1);
3414 $var = $self->deparse($var, 1);
3416 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
3417 if (!is_state $body->first and $body->first->name !~ /^(?:stub|leave|scope)$/) {
3418 confess unless $var eq '$_';
3419 $body = $body->first;
3420 return $self->deparse($body, 2) . " "
3421 . $self->keyword("foreach") . " ($ary)";
3423 $head = "foreach $var ($ary) ";
3424 } elsif ($kid->name eq "null") { # while/until
3426 $name = {"and" => "while", "or" => "until"}->{$kid->name};
3427 $cond = $kid->first;
3428 $body = $kid->first->sibling;
3429 } elsif ($kid->name eq "stub") { # bare and empty
3430 return "{;}"; # {} could be a hashref
3432 # If there isn't a continue block, then the next pointer for the loop
3433 # will point to the unstack, which is kid's last child, except
3434 # in a bare loop, when it will point to the leaveloop. When neither of
3435 # these conditions hold, then the second-to-last child is the continue
3436 # block (or the last in a bare loop).
3437 my $cont_start = $enter->nextop;
3441 if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
3443 $cont = $body->last;
3445 $cont = $body->first;
3446 while (!null($cont->sibling->sibling)) {
3447 $cont = $cont->sibling;
3450 my $state = $body->first;
3451 my $cuddle = $self->{'cuddle'};
3453 for (; $$state != $$cont; $state = $state->sibling) {
3454 push @states, $state;
3456 $body = $self->lineseq(undef, 0, @states);
3457 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
3458 $precond = "for ($init; ";
3459 $postcond = "; " . $self->deparse($cont, 1) .") ";
3462 $cont = $cuddle . "continue {\n\t" .
3463 $self->deparse($cont, 0) . "\n\b}\cK";
3466 return "" if !defined $body;
3468 $precond = "for ($init; ";
3472 $body = $self->deparse($body, 0);
3474 if ($precond) { # for(;;)
3475 $cond &&= $name eq 'until'
3476 ? listop($self, undef, 1, "not", $cond->first)
3477 : $self->deparse($cond, 1);
3478 $head = "$precond$cond$postcond";
3480 if ($name && !$head) {
3481 ref $cond and $cond = $self->deparse($cond, 1);
3482 $head = "$name ($cond) ";
3484 $head =~ s/^(for(?:each)?|while|until)/$self->keyword($1)/e;
3485 $body =~ s/;?$/;\n/;
3487 return $head . "{\n\t" . $body . "\b}" . $cont;
3490 sub pp_leaveloop { shift->loop_common(@_, "") }
3495 my $init = $self->deparse($op, 1);
3496 my $s = $op->sibling;
3497 my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling;
3498 return $self->loop_common($ll, $cx, $init);
3503 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
3507 my ($op, $expect_type) = @_;
3508 my $type = $op->type;
3509 return($type == $expect_type
3510 || ($type == OP_NULL && $op->targ == $expect_type));
3514 my($self, $op, $cx) = @_;
3515 if (class($op) eq "OP") {
3517 return $self->{'ex_const'} if $op->targ == OP_CONST;
3518 } elsif (class ($op) eq "COP") {
3519 return &pp_nextstate;
3520 } elsif ($op->first->name eq 'pushmark'
3521 or $op->first->name eq 'null'
3522 && $op->first->targ == OP_PUSHMARK
3523 && _op_is_or_was($op, OP_LIST)) {
3524 return $self->pp_list($op, $cx);
3525 } elsif ($op->first->name eq "enter") {
3526 return $self->pp_leave($op, $cx);
3527 } elsif ($op->first->name eq "leave") {
3528 return $self->pp_leave($op->first, $cx);
3529 } elsif ($op->first->name eq "scope") {
3530 return $self->pp_scope($op->first, $cx);
3531 } elsif ($op->targ == OP_STRINGIFY) {
3532 return $self->dquote($op, $cx);
3533 } elsif ($op->targ == OP_GLOB) {
3534 return $self->pp_glob(
3535 $op->first # entersub
3541 } elsif (!null($op->first->sibling) and
3542 $op->first->sibling->name eq "readline" and
3543 $op->first->sibling->flags & OPf_STACKED) {
3544 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
3545 . $self->deparse($op->first->sibling, 7),
3547 } elsif (!null($op->first->sibling) and
3548 $op->first->sibling->name eq "trans" and
3549 $op->first->sibling->flags & OPf_STACKED) {
3550 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
3551 . $self->deparse($op->first->sibling, 20),
3553 } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
3554 return ($self->lex_in_scope("&do") ? "CORE::do" : "do")
3555 . " {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
3556 } elsif (!null($op->first->sibling) and
3557 $op->first->sibling->name eq "null" and
3558 class($op->first->sibling) eq "UNOP" and
3559 $op->first->sibling->first->flags & OPf_STACKED and
3560 $op->first->sibling->first->name eq "rcatline") {
3561 return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
3562 . $self->deparse($op->first->sibling, 18),
3565 return $self->deparse($op->first, $cx);
3572 return $self->padname_sv($targ)->PVX;
3578 return substr($self->padname($op->targ), 1); # skip $/@/%
3583 my($op, $cx, $forbid_parens) = @_;
3584 my $targ = $op->targ;
3585 return $self->maybe_my($op, $cx, $self->padname($targ),
3586 $self->padname_sv($targ),
3590 sub pp_padav { pp_padsv(@_) }
3591 sub pp_padhv { pp_padsv(@_) }
3596 if (class($op) eq "PADOP") {
3597 return $self->padval($op->padix);
3598 } else { # class($op) eq "SVOP"
3606 my $gv = $self->gv_or_padgv($op);
3607 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
3608 $self->gv_name($gv), $cx));
3614 my $gv = $self->gv_or_padgv($op);
3615 return $self->gv_name($gv);
3618 sub pp_aelemfast_lex {
3621 my $name = $self->padname($op->targ);
3623 my $i = $op->private;
3624 $i -= 256 if $i > 127;
3625 return $name . "[" . ($i + $self->{'arybase'}) . "]";
3631 # optimised PADAV, pre 5.15
3632 return $self->pp_aelemfast_lex(@_) if ($op->flags & OPf_SPECIAL);
3634 my $gv = $self->gv_or_padgv($op);
3635 my($name,$quoted) = $self->stash_variable_name('@',$gv);
3636 $name = $quoted ? "$name->" : '$' . $name;
3637 my $i = $op->private;
3638 $i -= 256 if $i > 127;
3639 return $name . "[" . ($i + $self->{'arybase'}) . "]";
3644 my($op, $cx, $type) = @_;
3646 if (class($op) eq 'NULL' || !$op->can("first")) {
3647 carp("Unexpected op in pp_rv2x");
3650 my $kid = $op->first;
3651 if ($kid->name eq "gv") {
3652 return $self->stash_variable($type, $self->deparse($kid, 0), $cx);
3653 } elsif (is_scalar $kid) {
3654 my $str = $self->deparse($kid, 0);
3655 if ($str =~ /^\$([^\w\d])\z/) {
3656 # "$$+" isn't a legal way to write the scalar dereference
3657 # of $+, since the lexer can't tell you aren't trying to
3658 # do something like "$$ + 1" to get one more than your
3659 # PID. Either "${$+}" or "$${+}" are workable
3660 # disambiguations, but if the programmer did the former,
3661 # they'd be in the "else" clause below rather than here.
3662 # It's not clear if this should somehow be unified with
3663 # the code in dq and re_dq that also adds lexer
3664 # disambiguation braces.
3665 $str = '$' . "{$1}"; #'
3667 return $type . $str;
3669 return $type . "{" . $self->deparse($kid, 0) . "}";
3673 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
3674 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
3675 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
3681 if ($op->first->name eq "padav") {
3682 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
3684 return $self->maybe_local($op, $cx,
3685 $self->rv2x($op->first, $cx, '$#'));
3689 # skip down to the old, ex-rv2cv
3691 my ($self, $op, $cx) = @_;
3692 if (!null($op->first) && $op->first->name eq 'null' &&
3693 $op->first->targ == OP_LIST)
3695 return $self->rv2x($op->first->first->sibling, $cx, "&")
3698 return $self->rv2x($op, $cx, "")
3704 my($cx, @list) = @_;
3705 my @a = map $self->const($_, 6), @list;
3710 } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
3711 # collapse (-1,0,1,2) into (-1..2)
3712 my ($s, $e) = @a[0,-1];
3714 return $self->maybe_parens("$s..$e", $cx, 9)
3715 unless grep $i++ != $_, @a;
3717 return $self->maybe_parens(join(", ", @a), $cx, 6);
3723 my $kid = $op->first;
3724 if ($kid->name eq "const") { # constant list
3725 my $av = $self->const_sv($kid);
3726 return $self->list_const($cx, $av->ARRAY);
3728 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
3732 sub is_subscriptable {
3734 if ($op->name =~ /^[ahg]elem/) {
3736 } elsif ($op->name eq "entersub") {
3737 my $kid = $op->first;
3738 return 0 unless null $kid->sibling;
3740 $kid = $kid->sibling until null $kid->sibling;
3741 return 0 if is_scope($kid);
3743 return 0 if $kid->name eq "gv" || $kid->name eq "padcv";
3744 return 0 if is_scalar($kid);
3745 return is_subscriptable($kid);
3751 sub elem_or_slice_array_name
3754 my ($array, $left, $padname, $allow_arrow) = @_;
3756 if ($array->name eq $padname) {
3757 return $self->padany($array);
3758 } elsif (is_scope($array)) { # ${expr}[0]
3759 return "{" . $self->deparse($array, 0) . "}";
3760 } elsif ($array->name eq "gv") {
3761 ($array, my $quoted) =
3762 $self->stash_variable_name(
3763 $left eq '[' ? '@' : '%', $self->gv_or_padgv($array)
3765 if (!$allow_arrow && $quoted) {
3766 # This cannot happen.
3767 die "Invalid variable name $array for slice";
3769 return $quoted ? "$array->" : $array;
3770 } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
3771 return $self->deparse($array, 24);
3777 sub elem_or_slice_single_index
3782 $idx = $self->deparse($idx, 1);
3784 # Outer parens in an array index will confuse perl
3785 # if we're interpolating in a regular expression, i.e.
3786 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
3788 # If $self->{parens}, then an initial '(' will
3789 # definitely be paired with a final ')'. If
3790 # !$self->{parens}, the misleading parens won't
3791 # have been added in the first place.
3793 # [You might think that we could get "(...)...(...)"
3794 # where the initial and final parens do not match
3795 # each other. But we can't, because the above would
3796 # only happen if there's an infix binop between the
3797 # two pairs of parens, and *that* means that the whole
3798 # expression would be parenthesized as well.]
3800 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
3802 # Hash-element braces will autoquote a bareword inside themselves.
3803 # We need to make sure that C<$hash{warn()}> doesn't come out as
3804 # C<$hash{warn}>, which has a quite different meaning. Currently
3805 # B::Deparse will always quote strings, even if the string was a
3806 # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
3807 # for constant strings.) So we can cheat slightly here - if we see
3808 # a bareword, we know that it is supposed to be a function call.
3810 $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
3817 my ($op, $cx, $left, $right, $padname) = @_;
3818 my($array, $idx) = ($op->first, $op->first->sibling);
3820 $idx = $self->elem_or_slice_single_index($idx);
3822 unless ($array->name eq $padname) { # Maybe this has been fixed
3823 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
3825 if (my $array_name=$self->elem_or_slice_array_name
3826 ($array, $left, $padname, 1)) {
3827 return ($array_name =~ /->\z/
3829 : $array_name eq '#' ? '${#}' : "\$" . $array_name)
3830 . $left . $idx . $right;
3832 # $x[20][3]{hi} or expr->[20]
3833 my $arrow = is_subscriptable($array) ? "" : "->";
3834 return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
3839 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
3840 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
3845 my($glob, $part) = ($op->first, $op->last);
3846 $glob = $glob->first; # skip rv2gv
3847 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
3848 my $scope = is_scope($glob);
3849 $glob = $self->deparse($glob, 0);
3850 $part = $self->deparse($part, 1);
3851 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
3856 my ($op, $cx, $left, $right, $regname, $padname) = @_;
3858 my(@elems, $kid, $array, $list);
3859 if (class($op) eq "LISTOP") {
3861 } else { # ex-hslice inside delete()
3862 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
3866 $array = $array->first
3867 if $array->name eq $regname or $array->name eq "null";
3868 $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
3869 $kid = $op->first->sibling; # skip pushmark
3870 if ($kid->name eq "list") {
3871 $kid = $kid->first->sibling; # skip list, pushmark
3872 for (; !null $kid; $kid = $kid->sibling) {
3873 push @elems, $self->deparse($kid, 6);
3875 $list = join(", ", @elems);
3877 $list = $self->elem_or_slice_single_index($kid);
3880 $lead = '%' if $op->name =~ /^kv/i;
3881 return $lead . $array . $left . $list . $right;
3884 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
3885 sub pp_kvaslice { slice(@_, "[", "]", "rv2av", "padav") }
3886 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
3887 sub pp_kvhslice { slice(@_, "{", "}", "rv2hv", "padhv") }
3892 my $idx = $op->first;
3893 my $list = $op->last;
3895 $list = $self->deparse($list, 1);
3896 $idx = $self->deparse($idx, 1);
3897 return "($list)" . "[$idx]";
3902 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
3907 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
3913 my $kid = $op->first->sibling; # skip pushmark
3914 my($meth, $obj, @exprs);
3915 if ($kid->name eq "list" and want_list $kid) {
3916 # When an indirect object isn't a bareword but the args are in
3917 # parens, the parens aren't part of the method syntax (the LLAFR
3918 # doesn't apply), but they make a list with OPf_PARENS set that
3919 # doesn't get flattened by the append_elem that adds the method,
3920 # making a (object, arg1, arg2, ...) list where the object
3921 # usually is. This can be distinguished from
3922 # '($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
3923 # object) because in the later the list is in scalar context
3924 # as the left side of -> always is, while in the former
3925 # the list is in list context as method arguments always are.
3926 # (Good thing there aren't method prototypes!)
3927 $meth = $kid->sibling;
3928 $kid = $kid->first->sibling; # skip pushmark
3930 $kid = $kid->sibling;
3931 for (; not null $kid; $kid = $kid->sibling) {
3936 $kid = $kid->sibling;
3937 for (; !null ($kid->sibling) && $kid->name!~/^method(?:_named)?\z/;
3938 $kid = $kid->sibling) {
3944 if ($meth->name eq "method_named") {
3945 $meth = $self->meth_sv($meth)->PV;
3946 } elsif ($meth->name eq "method_super") {
3947 $meth = "SUPER::".$self->meth_sv($meth)->PV;
3949 $meth = $meth->first;
3950 if ($meth->name eq "const") {
3951 # As of 5.005_58, this case is probably obsoleted by the
3952 # method_named case above
3953 $meth = $self->const_sv($meth)->PV; # needs to be bare
3957 return { method => $meth, variable_method => ref($meth),
3958 object => $obj, args => \@exprs },
3962 # compat function only
3965 my $info = $self->_method(@_);
3966 return $self->e_method( $self->_method(@_) );
3970 my ($self, $info, $cx) = @_;
3971 my $obj = $self->deparse($info->{object}, 24);
3973 my $meth = $info->{method};
3974 $meth = $self->deparse($meth, 1) if $info->{variable_method};
3975 my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
3976 if ($info->{object}->name eq 'scope' && want_list $info->{object}) {
3977 # method { $object }
3978 # This must be deparsed this way to preserve list context
3980 my $need_paren = $cx >= 6;
3981 return '(' x $need_paren
3982 . $meth . substr($obj,2) # chop off the "do"
3984 . ')' x $need_paren;
3986 my $kid = $obj . "->" . $meth;
3988 return $kid . "(" . $args . ")"; # parens mandatory
3994 # returns "&" if the prototype doesn't match the args,
3995 # or ("", $args_after_prototype_demunging) if it does.
3998 return "&" if $self->{'noproto'};
3999 my($proto, @args) = @_;
4003 # An unbackslashed @ or % gobbles up the rest of the args
4004 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
4007 $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)\s*//;
4010 return "&" if @args;
4011 } elsif ($chr eq ";") {
4013 } elsif ($chr eq "@" or $chr eq "%") {
4014 push @reals, map($self->deparse($_, 6), @args);
4019 if ($chr eq "\$" || $chr eq "_") {
4020 if (want_scalar $arg) {
4021 push @reals, $self->deparse($arg, 6);
4025 } elsif ($chr eq "&") {
4026 if ($arg->name =~ /^(s?refgen|undef)$/) {
4027 push @reals, $self->deparse($arg, 6);
4031 } elsif ($chr eq "*") {
4032 if ($arg->name =~ /^s?refgen$/
4033 and $arg->first->first->name eq "rv2gv")
4035 $real = $arg->first->first; # skip refgen, null
4036 if ($real->first->name eq "gv") {
4037 push @reals, $self->deparse($real, 6);
4039 push @reals, $self->deparse($real->first, 6);
4044 } elsif (substr($chr, 0, 1) eq "\\") {
4046 if ($arg->name =~ /^s?refgen$/ and
4047 !null($real = $arg->first) and
4048 ($chr =~ /\$/ && is_scalar($real->first)
4050 && class($real->first->sibling) ne 'NULL'
4051 && $real->first->sibling->name
4054 && class($real->first->sibling) ne 'NULL'
4055 && $real->first->sibling->name
4057 #or ($chr =~ /&/ # This doesn't work
4058 # && $real->first->name eq "rv2cv")
4060 && $real->first->name eq "rv2gv")))
4062 push @reals, $self->deparse($real, 6);
4069 return "&" if $proto and !$doneok; # too few args and no ';'
4070 return "&" if @args; # too many args
4071 return ("", join ", ", @reals);
4077 return $self->e_method($self->_method($op, $cx))
4078 unless null $op->first->sibling;
4082 if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
4084 } elsif ($op->private & OPpENTERSUB_AMPER) {
4088 $kid = $kid->first->sibling; # skip ex-list, pushmark
4089 for (; not null $kid->sibling; $kid = $kid->sibling) {
4094 if (is_scope($kid)) {
4096 $kid = "{" . $self->deparse($kid, 0) . "}";
4097 } elsif ($kid->first->name eq "gv") {
4098 my $gv = $self->gv_or_padgv($kid->first);
4100 if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL"
4101 || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') {
4102 $proto = $cv->PV if $cv->FLAGS & SVf_POK;
4104 $simple = 1; # only calls of named functions can be prototyped
4105 $kid = $self->deparse($kid, 24);
4107 # Fully qualify any sub name that conflicts with a lexical.
4108 if ($self->lex_in_scope("&$kid")
4109 || $self->lex_in_scope("&$kid", 1))
4113 if ($kid eq 'main::') {
4117 if ($kid !~ /::/ && $kid ne 'x') {
4118 # Fully qualify any sub name that is also a keyword. While
4119 # we could check the import flag, we cannot guarantee that
4120 # the code deparsed so far would set that flag, so we qual-
4121 # ify the names regardless of importation.
4122 if (exists $feature_keywords{$kid}) {
4123 $fq++ if $self->feature_enabled($kid);
4124 } elsif (do { local $@; local $SIG{__DIE__};
4125 eval { () = prototype "CORE::$kid"; 1 } }) {
4129 if ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
4130 $kid = single_delim("q", "'", $kid, $self) . '->';
4134 $fq and substr $kid, 0, 0, = $self->{'curstash'}.'::';
4135 } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
4137 $kid = $self->deparse($kid, 24);
4140 my $arrow = is_subscriptable($kid->first) || $kid->first->name eq "padcv" ? "" : "->";
4141 $kid = $self->deparse($kid, 24) . $arrow;
4144 # Doesn't matter how many prototypes there are, if
4145 # they haven't happened yet!
4149 no warnings 'uninitialized';
4150 $declared = exists $self->{'subs_declared'}{$kid}
4152 defined &{ ${$self->{'curstash'}."::"}{$kid} }
4154 $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
4155 && defined prototype $self->{'curstash'}."::".$kid
4157 if (!$declared && defined($proto)) {
4158 # Avoid "too early to check prototype" warning
4159 ($amper, $proto) = ('&');
4164 if ($declared and defined $proto and not $amper) {
4165 ($amper, $args) = $self->check_proto($proto, @exprs);
4166 if ($amper eq "&") {
4167 $args = join(", ", map($self->deparse($_, 6), @exprs));
4170 $args = join(", ", map($self->deparse($_, 6), @exprs));
4172 if ($prefix or $amper) {
4173 if ($kid eq '&') { $kid = "{$kid}" } # &{&} cannot be written as &&
4174 if ($op->flags & OPf_STACKED) {
4175 return $prefix . $amper . $kid . "(" . $args . ")";
4177 return $prefix . $amper. $kid;
4180 # It's a syntax error to call CORE::GLOBAL::foo with a prefix,
4181 # so it must have been translated from a keyword call. Translate
4183 $kid =~ s/^CORE::GLOBAL:://;
4185 my $dproto = defined($proto) ? $proto : "undefined";
4187 return "$kid(" . $args . ")";
4188 } elsif ($dproto =~ /^\s*\z/) {
4190 } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
4191 # is_scalar is an excessively conservative test here:
4192 # really, we should be comparing to the precedence of the
4193 # top operator of $exprs[0] (ala unop()), but that would
4194 # take some major code restructuring to do right.
4195 return $self->maybe_parens_func($kid, $args, $cx, 16);
4196 } elsif ($dproto ne '$' and defined($proto) || $simple) { #'
4197 return $self->maybe_parens_func($kid, $args, $cx, 5);
4199 return "$kid(" . $args . ")";
4204 sub pp_enterwrite { unop(@_, "write") }
4206 # escape things that cause interpolation in double quotes,
4207 # but not character escapes
4210 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
4218 # Matches any string which is balanced with respect to {braces}
4229 # the same, but treat $|, $), $( and $ at the end of the string differently
4243 (\(\?\??\{$bal\}\)) # $4
4249 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
4254 # This is for regular expressions with the /x modifier
4255 # We have to leave comments unmangled.
4256 sub re_uninterp_extended {
4269 ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
4270 | \#[^\n]* # (skip over comments)
4277 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
4283 my %unctrl = # portable to EBCDIC
4285 "\c@" => '\c@', # unused
4312 "\c[" => '\c[', # unused
4313 "\c\\" => '\c\\', # unused
4314 "\c]" => '\c]', # unused
4315 "\c_" => '\c_', # unused
4318 # character escapes, but not delimiters that might need to be escaped
4319 sub escape_str { # ASCII, UTF8
4321 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
4323 # $str =~ s/\cH/\\b/g; # \b means something different in a regex
4329 $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
4330 $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
4334 # For regexes with the /x modifier.
4335 # Leave whitespace unmangled.
4336 sub escape_extended_re {
4338 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
4339 $str =~ s/([[:^print:]])/
4340 ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
4341 $str =~ s/\n/\n\f/g;
4345 # Don't do this for regexen
4348 $str =~ s/\\/\\\\/g;
4352 # Remove backslashes which precede literal control characters,
4353 # to avoid creating ambiguity when we escape the latter.
4357 # the insane complexity here is due to the behaviour of "\c\"
4358 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
4362 sub balanced_delim {
4364 my @str = split //, $str;
4365 my($ar, $open, $close, $fail, $c, $cnt, $last_bs);
4366 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
4367 ($open, $close) = @$ar;
4368 $fail = 0; $cnt = 0; $last_bs = 0;
4371 $fail = 1 if $last_bs;
4373 } elsif ($c eq $close) {
4374 $fail = 1 if $last_bs;
4382 $last_bs = $c eq '\\';
4384 $fail = 1 if $cnt != 0;
4385 return ($open, "$open$str$close") if not $fail;
4391 my($q, $default, $str, $self) = @_;
4392 return "$default$str$default" if $default and index($str, $default) == -1;
4393 my $coreq = $self->keyword($q); # maybe CORE::q
4395 (my $succeed, $str) = balanced_delim($str);
4396 return "$coreq$str" if $succeed;
4398 for my $delim ('/', '"', '#') {
4399 return "$coreq$delim" . $str . $delim if index($str, $delim) == -1;
4402 $str =~ s/$default/\\$default/g;
4403 return "$default$str$default";
4406 return "$coreq/$str/";
4411 BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
4413 # Split a floating point number into an integer mantissa and a binary
4414 # exponent. Assumes you've already made sure the number isn't zero or
4415 # some weird infinity or NaN.
4419 if ($f == int($f)) {
4420 while ($f % 2 == 0) {
4425 while ($f != int($f)) {
4430 my $mantissa = sprintf("%.0f", $f);
4431 return ($mantissa, $exponent);
4437 if ($self->{'use_dumper'}) {
4438 return $self->const_dumper($sv, $cx);
4440 if (class($sv) eq "SPECIAL") {
4441 # sv_undef, sv_yes, sv_no
4442 return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1];
4444 if (class($sv) eq "NULL") {
4447 # convert a version object into the "v1.2.3" string in its V magic
4448 if ($sv->FLAGS & SVs_RMG) {
4449 for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
4450 return $mg->PTR if $mg->TYPE eq 'V';
4454 if ($sv->FLAGS & SVf_IOK) {
4455 my $str = $sv->int_value;
4456 $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
4458 } elsif ($sv->FLAGS & SVf_NOK) {
4461 if (pack("F", $nv) eq pack("F", 0)) {
4466 return $self->maybe_parens("-.0", $cx, 21);
4468 } elsif (1/$nv == 0) {
4471 return $self->maybe_parens("9**9**9", $cx, 22);
4474 return $self->maybe_parens("-9**9**9", $cx, 21);
4476 } elsif ($nv != $nv) {
4478 if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
4480 return "sin(9**9**9)";
4481 } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
4483 return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
4486 my $hex = unpack("h*", pack("F", $nv));
4487 return qq'unpack("F", pack("h*", "$hex"))';
4490 # first, try the default stringification
4493 # failing that, try using more precision
4494 $str = sprintf("%.${max_prec}g", $nv);
4495 # if (pack("F", $str) ne pack("F", $nv)) {
4497 # not representable in decimal with whatever sprintf()
4498 # and atof() Perl is using here.
4499 my($mant, $exp) = split_float($nv);
4500 return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
4503 $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
4505 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
4507 if (class($ref) eq "AV") {
4508 return "[" . $self->list_const(2, $ref->ARRAY) . "]";
4509 } elsif (class($ref) eq "HV") {
4510 my %hash = $ref->ARRAY;
4512 for my $k (sort keys %hash) {
4513 push @elts, "$k => " . $self->const($hash{$k}, 6);
4515 return "{" . join(", ", @elts) . "}";
4516 } elsif (class($ref) eq "CV") {
4518 if ($] > 5.0150051) {
4519 require overloading;
4520 unimport overloading;
4523 if ($] > 5.0150051 && $self->{curcv} &&
4524 $self->{curcv}->object_2svref == $ref->object_2svref) {
4525 return $self->keyword("__SUB__");
4527 return "sub " . $self->deparse_sub($ref);
4529 if ($ref->FLAGS & SVs_SMG) {
4530 for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
4531 if ($mg->TYPE eq 'r') {
4532 my $re = re_uninterp(escape_str(re_unback($mg->precomp)));
4533 return single_delim("qr", "", $re, $self);
4538 my $const = $self->const($ref, 20);
4539 if ($self->{in_subst_repl} && $const =~ /^[0-9]/) {
4540 $const = "($const)";
4542 return $self->maybe_parens("\\$const", $cx, 20);
4543 } elsif ($sv->FLAGS & SVf_POK) {
4545 if ($str =~ /[[:^print:]]/) {
4546 return single_delim("qq", '"',
4547 uninterp(escape_str unback $str), $self);
4549 return single_delim("q", "'", unback($str), $self);
4559 my $ref = $sv->object_2svref();
4560 my $dumper = Data::Dumper->new([$$ref], ['$v']);
4561 $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
4562 my $str = $dumper->Dump();
4563 if ($str =~ /^\$v/) {
4564 return '${my ' . $str . ' \$v}';
4574 # the constant could be in the pad (under useithreads)
4575 $sv = $self->padval($op->targ) unless $$sv;
4582 my $sv = $op->meth_sv;
4583 # the constant could be in the pad (under useithreads)
4584 $sv = $self->padval($op->targ) unless $$sv;
4591 if ($op->private & OPpCONST_ARYBASE) {
4594 # if ($op->private & OPpCONST_BARE) { # trouble with '=>' autoquoting
4595 # return $self->const_sv($op)->PV;
4597 my $sv = $self->const_sv($op);
4598 return $self->const($sv, $cx);
4604 my $type = $op->name;
4605 if ($type eq "const") {
4606 return '$[' if $op->private & OPpCONST_ARYBASE;
4607 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
4608 } elsif ($type eq "concat") {
4609 my $first = $self->dq($op->first);
4610 my $last = $self->dq($op->last);
4612 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
4613 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
4614 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
4615 || ($last =~ /^[:'{\[\w_]/ && #'
4616 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
4618 return $first . $last;
4619 } elsif ($type eq "uc") {
4620 return '\U' . $self->dq($op->first->sibling) . '\E';
4621 } elsif ($type eq "lc") {
4622 return '\L' . $self->dq($op->first->sibling) . '\E';
4623 } elsif ($type eq "ucfirst") {
4624 return '\u' . $self->dq($op->first->sibling);
4625 } elsif ($type eq "lcfirst") {
4626 return '\l' . $self->dq($op->first->sibling);
4627 } elsif ($type eq "quotemeta") {
4628 return '\Q' . $self->dq($op->first->sibling) . '\E';
4629 } elsif ($type eq "fc") {
4630 return '\F' . $self->dq($op->first->sibling) . '\E';
4631 } elsif ($type eq "join") {
4632 return $self->deparse($op->last, 26); # was join($", @ary)
4634 return $self->deparse($op, 26);
4641 # skip pushmark if it exists (readpipe() vs ``)
4642 my $child = $op->first->sibling->isa('B::NULL')
4643 ? $op->first : $op->first->sibling;
4644 if ($self->pure_string($child)) {
4645 return single_delim("qx", '`', $self->dq($child, 1), $self);
4647 unop($self, @_, "readpipe");
4653 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
4654 return $self->deparse($kid, $cx) if $self->{'unquote'};
4655 $self->maybe_targmy($kid, $cx,
4656 sub {single_delim("qq", '"', $self->dq($_[1]),
4660 # OP_STRINGIFY is a listop, but it only ever has one arg
4662 my ($self, $op, $cx) = @_;
4663 my $kid = $op->first->sibling;
4664 while ($kid->name eq 'null' && !null($kid->first)) {
4667 if ($kid->name =~ /^(?:const|padsv|rv2sv|av2arylen|gvsv
4668 |aelemfast(?:_lex)?|[ah]elem|join|concat)\z/x) {
4669 maybe_targmy(@_, \&dquote);
4672 # Actually an optimised join.
4673 my $result = listop(@_,"join");
4674 $result =~ s/join([( ])/join$1$self->{'ex_const'}, /;
4679 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
4680 # note that tr(from)/to/ is OK, but not tr/from/(to)
4682 my($from, $to) = @_;
4683 my($succeed, $delim);
4684 if ($from !~ m[/] and $to !~ m[/]) {
4685 return "/$from/$to/";
4686 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
4687 if (($succeed, $to) = balanced_delim($to) and $succeed) {
4690 for $delim ('/', '"', '#') { # note no "'" -- s''' is special
4691 return "$from$delim$to$delim" if index($to, $delim) == -1;
4694 return "$from/$to/";
4697 for $delim ('/', '"', '#') { # note no '
4698 return "$delim$from$delim$to$delim"
4699 if index($to . $from, $delim) == -1;
4701 $from =~ s[/][\\/]g;
4703 return "/$from/$to/";
4707 # Only used by tr///, so backslashes hyphens
4710 if ($n == ord '\\') {
4712 } elsif ($n == ord "-") {
4714 } elsif ($n >= ord(' ') and $n <= ord('~')) {
4716 } elsif ($n == ord "\a") {
4718 } elsif ($n == ord "\b") {
4720 } elsif ($n == ord "\t") {
4722 } elsif ($n == ord "\n") {
4724 } elsif ($n == ord "\e") {
4726 } elsif ($n == ord "\f") {
4728 } elsif ($n == ord "\r") {
4730 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
4731 return '\\c' . chr(ord("@") + $n);
4733 # return '\x' . sprintf("%02x", $n);
4734 return '\\' . sprintf("%03o", $n);
4740 my($str, $c, $tr) = ("");
4741 for ($c = 0; $c < @chars; $c++) {
4744 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
4745 $chars[$c + 2] == $tr + 2)
4747 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
4750 $str .= pchr($chars[$c]);
4756 sub tr_decode_byte {
4757 my($table, $flags) = @_;
4758 my(@table) = unpack("s*", $table);
4759 splice @table, 0x100, 1; # Number of subsequent elements
4760 my($c, $tr, @from, @to, @delfrom, $delhyphen);
4761 if ($table[ord "-"] != -1 and
4762 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
4764 $tr = $table[ord "-"];
4765 $table[ord "-"] = -1;
4769 } else { # -2 ==> delete
4773 for ($c = 0; $c < @table; $c++) {
4776 push @from, $c; push @to, $tr;
4777 } elsif ($tr == -2) {
4781 @from = (@from, @delfrom);
4782 if ($flags & OPpTRANS_COMPLEMENT) {
4785 @from{@from} = (1) x @from;
4786 for ($c = 0; $c < 256; $c++) {
4787 push @newfrom, $c unless $from{$c};
4791 unless ($flags & OPpTRANS_DELETE || !@to) {
4792 pop @to while $#to and $to[$#to] == $to[$#to -1];
4795 $from = collapse(@from);
4796 $to = collapse(@to);
4797 $from .= "-" if $delhyphen;
4798 return ($from, $to);
4803 if ($x == ord "-") {
4805 } elsif ($x == ord "\\") {
4812 # XXX This doesn't yet handle all cases correctly either
4814 sub tr_decode_utf8 {
4815 my($swash_hv, $flags) = @_;
4816 my %swash = $swash_hv->ARRAY;
4818 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
4819 my $none = $swash{"NONE"}->IV;
4820 my $extra = $none + 1;
4821 my(@from, @delfrom, @to);
4823 foreach $line (split /\n/, $swash{'LIST'}->PV) {
4824 my($min, $max, $result) = split(/\t/, $line);
4831 $result = hex $result;
4832 if ($result == $extra) {
4833 push @delfrom, [$min, $max];
4835 push @from, [$min, $max];
4836 push @to, [$result, $result + $max - $min];
4839 for my $i (0 .. $#from) {
4840 if ($from[$i][0] == ord '-') {
4841 unshift @from, splice(@from, $i, 1);
4842 unshift @to, splice(@to, $i, 1);
4844 } elsif ($from[$i][1] == ord '-') {
4847 unshift @from, ord '-';
4848 unshift @to, ord '-';
4852 for my $i (0 .. $#delfrom) {
4853 if ($delfrom[$i][0] == ord '-') {
4854 push @delfrom, splice(@delfrom, $i, 1);
4856 } elsif ($delfrom[$i][1] == ord '-') {
4858 push @delfrom, ord '-';
4862 if (defined $final and $to[$#to][1] != $final) {
4863 push @to, [$final, $final];
4865 push @from, @delfrom;
4866 if ($flags & OPpTRANS_COMPLEMENT) {
4869 for my $i (0 .. $#from) {
4870 push @newfrom, [$next, $from[$i][0] - 1];
4871 $next = $from[$i][1] + 1;
4874 for my $range (@newfrom) {
4875 if ($range->[0] <= $range->[1]) {
4880 my($from, $to, $diff);
4881 for my $chunk (@from) {
4882 $diff = $chunk->[1] - $chunk->[0];
4884 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
4885 } elsif ($diff == 1) {
4886 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
4888 $from .= tr_chr($chunk->[0]);
4891 for my $chunk (@to) {
4892 $diff = $chunk->[1] - $chunk->[0];
4894 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
4895 } elsif ($diff == 1) {
4896 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
4898 $to .= tr_chr($chunk->[0]);
4901 #$final = sprintf("%04x", $final) if defined $final;
4902 #$none = sprintf("%04x", $none) if defined $none;
4903 #$extra = sprintf("%04x", $extra) if defined $extra;
4904 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
4905 #print STDERR $swash{'LIST'}->PV;
4906 return (escape_str($from), escape_str($to));
4911 my($op, $cx, $morflags) = @_;
4913 my $class = class($op);
4914 my $priv_flags = $op->private;
4915 if ($class eq "PVOP") {
4916 ($from, $to) = tr_decode_byte($op->pv, $priv_flags);
4917 } elsif ($class eq "PADOP") {
4919 = tr_decode_utf8($self->padval($op->padix)->RV, $priv_flags);
4920 } else { # class($op) eq "SVOP"
4921 ($from, $to) = tr_decode_utf8($op->sv->RV, $priv_flags);
4924 $flags .= "c" if $priv_flags & OPpTRANS_COMPLEMENT;
4925 $flags .= "d" if $priv_flags & OPpTRANS_DELETE;
4926 $to = "" if $from eq $to and $flags eq "";
4927 $flags .= "s" if $priv_flags & OPpTRANS_SQUASH;
4928 $flags .= $morflags if defined $morflags;
4929 my $ret = $self->keyword("tr") . double_delim($from, $to) . $flags;
4930 if (my $targ = $op->targ) {
4931 return $self->maybe_parens($self->padname($targ) . " =~ $ret",
4937 sub pp_transr { push @_, 'r'; goto &pp_trans }
4939 sub re_dq_disambiguate {
4940 my ($first, $last) = @_;
4941 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
4942 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
4943 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
4944 || ($last =~ /^[{\[\w_]/ &&
4945 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
4946 return $first . $last;
4949 # Like dq(), but different
4952 my ($op, $extended) = @_;
4954 my $type = $op->name;
4955 if ($type eq "const") {
4956 return '$[' if $op->private & OPpCONST_ARYBASE;
4957 my $unbacked = re_unback($self->const_sv($op)->as_string);
4958 return re_uninterp_extended(escape_extended_re($unbacked))
4960 return re_uninterp(escape_str($unbacked));
4961 } elsif ($type eq "concat") {
4962 my $first = $self->re_dq($op->first, $extended);
4963 my $last = $self->re_dq($op->last, $extended);
4964 return re_dq_disambiguate($first, $last);
4965 } elsif ($type eq "uc") {
4966 return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
4967 } elsif ($type eq "lc") {
4968 return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
4969 } elsif ($type eq "ucfirst") {
4970 return '\u' . $self->re_dq($op->first->sibling, $extended);
4971 } elsif ($type eq "lcfirst") {
4972 return '\l' . $self->re_dq($op->first->sibling, $extended);
4973 } elsif ($type eq "quotemeta") {
4974 return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
4975 } elsif ($type eq "fc") {
4976 return '\F' . $self->re_dq($op->first->sibling, $extended) . '\E';
4977 } elsif ($type eq "join") {
4978 return $self->deparse($op->last, 26); # was join($", @ary)
4980 my $ret = $self->deparse($op, 26);
4981 $ret =~ s/^\$([(|)])\z/\${$1}/; # $( $| $) need braces
4987 my ($self, $op) = @_;
4988 return 0 if null $op;
4989 my $type = $op->name;
4991 if ($type eq 'const' || $type eq 'av2arylen') {
4994 elsif ($type =~ /^(?:[ul]c(first)?|fc)$/ || $type eq 'quotemeta') {
4995 return $self->pure_string($op->first->sibling);
4997 elsif ($type eq 'join') {
4998 my $join_op = $op->first->sibling; # Skip pushmark
4999 return 0 unless $join_op->name eq 'null' && $join_op->targ == OP_RV2SV;
5001 my $gvop = $join_op->first;
5002 return 0 unless $gvop->name eq 'gvsv';
5003 return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
5005 return 0 unless ${$join_op->sibling} eq ${$op->last};
5006 return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
5008 elsif ($type eq 'concat') {
5009 return $self->pure_string($op->first)
5010 && $self->pure_string($op->last);
5012 elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
5015 elsif ($type eq "null" and $op->can('first') and not null $op->first and
5016 ($op->first->name eq "null" and $op->first->can('first')
5017 and not null $op->first->first and
5018 $op->first->first->name eq "aelemfast"
5020 $op->first->name =~ /^aelemfast(?:_lex)?\z/
5033 my($op, $cx, $extended) = @_;
5034 my $kid = $op->first;
5035 $kid = $kid->first if $kid->name eq "regcmaybe";
5036 $kid = $kid->first if $kid->name eq "regcreset";
5037 if ($kid->name eq "null" and !null($kid->first)
5038 and $kid->first->name eq 'pushmark')
5041 $kid = $kid->first->sibling;
5042 while (!null($kid)) {
5044 my $last = $self->re_dq($kid, $extended);
5045 $str = re_dq_disambiguate($first, $last);
5046 $kid = $kid->sibling;
5051 return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
5052 return ($self->deparse($kid, $cx), 0);
5056 my ($self, $op, $cx) = @_;
5057 return (($self->regcomp($op, $cx, 0))[0]);
5061 my ($self, $op) = @_;
5063 my $pmflags = $op->pmflags;
5064 $flags .= "g" if $pmflags & PMf_GLOBAL;
5065 $flags .= "i" if $pmflags & PMf_FOLD;
5066 $flags .= "m" if $pmflags & PMf_MULTILINE;
5067 $flags .= "o" if $pmflags & PMf_KEEP;
5068 $flags .= "s" if $pmflags & PMf_SINGLELINE;
5069 $flags .= "x" if $pmflags & PMf_EXTENDED;
5070 $flags .= "x" if $pmflags & PMf_EXTENDED_MORE;
5071 $flags .= "p" if $pmflags & RXf_PMf_KEEPCOPY;
5072 if (my $charset = $pmflags & RXf_PMf_CHARSET) {
5073 # Hardcoding this is fragile, but B does not yet export the
5074 # constants we need.
5075 $flags .= qw(d l u a aa)[$charset >> 6]
5077 # The /d flag is indicated by 0; only show it if necessary.
5078 elsif ($self->{hinthash} and
5079 $self->{hinthash}{reflags_charset}
5080 || $self->{hinthash}{feature_unicode}
5081 or $self->{hints} & $feature::hint_mask
5082 && ($self->{hints} & $feature::hint_mask)
5083 != $feature::hint_mask
5085 $self->{hints} & $feature::hint_uni8bit;
5093 # osmic acid -- see osmium tetroxide
5096 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
5097 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
5098 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
5102 my($op, $cx, $name, $delim) = @_;
5103 my $kid = $op->first;
5104 my ($binop, $var, $re) = ("", "", "");
5105 if ($op->flags & OPf_STACKED) {
5107 $var = $self->deparse($kid, 20);
5108 $kid = $kid->sibling;
5110 elsif ($name eq 'match' and my $targ = $op->targ) {
5112 $var = $self->padname($targ);
5115 my $pmflags = $op->pmflags;
5116 my $extended = ($pmflags & PMf_EXTENDED);
5117 my $rhs_bound_to_defsv;
5119 my $unbacked = re_unback($op->precomp);
5121 $re = re_uninterp_extended(escape_extended_re($unbacked));
5123 $re = re_uninterp(escape_str(re_unback($op->precomp)));
5125 } elsif ($kid->name ne 'regcomp') {
5126 carp("found ".$kid->name." where regcomp expected");
5128 ($re, $quote) = $self->regcomp($kid, 21, $extended);
5129 my $matchop = $kid->first;
5130 if ($matchop->name eq 'regcrest') {
5131 $matchop = $matchop->first;
5133 if ($matchop->name =~ /^(?:match|transr?|subst)\z/
5134 && $matchop->flags & OPf_SPECIAL) {
5135 $rhs_bound_to_defsv = 1;
5139 $flags .= "c" if $pmflags & PMf_CONTINUE;
5140 $flags .= $self->re_flags($op);
5141 $flags = join '', sort split //, $flags;
5142 $flags = $matchwords{$flags} if $matchwords{$flags};
5143 if ($pmflags & PMf_ONCE) { # only one kind of delimiter works here
5145 $re = $self->keyword("m") . "?$re?"; # explicit 'm' is required
5147 $re = single_delim($name, $delim, $re, $self);
5149 $re = $re . $flags if $quote;
5152 $self->maybe_parens(
5154 ? "$var =~ (\$_ =~ $re)"
5163 sub pp_match { matchop(@_, "m", "/") }
5164 sub pp_pushre { matchop(@_, "m", "/") }
5165 sub pp_qr { matchop(@_, "qr", "") }
5167 sub pp_runcv { unop(@_, "__SUB__"); }
5170 maybe_targmy(@_, \&split);
5175 my($kid, @exprs, $ary, $expr);
5178 # For our kid (an OP_PUSHRE), pmreplroot is never actually the
5179 # root of a replacement; it's either empty, or abused to point to
5180 # the GV for an array we split into (an optimization to save
5181 # assignment overhead). Depending on whether we're using ithreads,
5182 # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
5183 # figures out for us which it is.
5184 my $replroot = $kid->pmreplroot;
5186 my $stacked = $op->flags & OPf_STACKED;
5187 if (ref($replroot) eq "B::GV") {
5189 } elsif (!ref($replroot) and $replroot > 0) {
5190 $gv = $self->padval($replroot);
5191 } elsif ($kid->targ) {
5192 $ary = $self->padname($kid->targ)
5193 } elsif ($stacked) {
5194 $ary = $self->deparse($op->last, 7);
5196 $ary = $self->maybe_local(@_,
5197 $self->stash_variable('@',
5198 $self->gv_name($gv),
5202 # Skip the last kid when OPf_STACKED is set, since it is the array
5204 for (; !null($stacked ? $kid->sibling : $kid); $kid = $kid->sibling) {
5205 push @exprs, $self->deparse($kid, 6);
5208 # handle special case of split(), and split(' ') that compiles to /\s+/
5209 # Under 5.10, the reflags may be undef if the split regexp isn't a constant
5210 # Under 5.17.5-5.17.9, the special flag is on split itself.
5212 if ( $op->flags & OPf_SPECIAL
5214 $kid->flags & OPf_SPECIAL
5215 and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
5216 : ($kid->reflags || 0) & RXf_SKIPWHITE()
5223 $expr = "split(" . join(", ", @exprs) . ")";
5225 return $self->maybe_parens("$ary = $expr", $cx, 7);
5231 # oxime -- any of various compounds obtained chiefly by the action of
5232 # hydroxylamine on aldehydes and ketones and characterized by the
5233 # bivalent grouping C=NOH [Webster's Tenth]
5236 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
5237 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
5238 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
5239 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi', 'rogue',
5240 'sir', 'rise', 'smore', 'more', 'seer', 'rome', 'gore', 'grim', 'grime',
5241 'or', 'rose', 'rosie');
5246 my $kid = $op->first;
5247 my($binop, $var, $re, $repl) = ("", "", "", "");
5248 if ($op->flags & OPf_STACKED) {
5250 $var = $self->deparse($kid, 20);
5251 $kid = $kid->sibling;
5253 elsif (my $targ = $op->targ) {
5255 $var = $self->padname($targ);
5258 my $pmflags = $op->pmflags;
5259 if (null($op->pmreplroot)) {
5261 $kid = $kid->sibling;
5263 $repl = $op->pmreplroot->first; # skip substcont
5265 while ($repl->name eq "entereval") {
5266 $repl = $repl->first;
5270 local $self->{in_subst_repl} = 1;
5271 if ($pmflags & PMf_EVAL) {
5272 $repl = $self->deparse($repl->first, 0);
5274 $repl = $self->dq($repl);
5277 my $extended = ($pmflags & PMf_EXTENDED);
5279 my $unbacked = re_unback($op->precomp);
5281 $re = re_uninterp_extended(escape_extended_re($unbacked));
5284 $re = re_uninterp(escape_str($unbacked));
5287 ($re) = $self->regcomp($kid, 1, $extended);
5289 $flags .= "r" if $pmflags & PMf_NONDESTRUCT;
5290 $flags .= "e" if $pmflags & PMf_EVAL;
5291 $flags .= $self->re_flags($op);
5292 $flags = join '', sort split //, $flags;
5293 $flags = $substwords{$flags} if $substwords{$flags};
5294 my $core_s = $self->keyword("s"); # maybe CORE::s
5296 return $self->maybe_parens("$var =~ $core_s"
5297 . double_delim($re, $repl) . $flags,
5300 return "$core_s". double_delim($re, $repl) . $flags;
5304 sub is_lexical_subs {
5307 return 0 if $op->name !~ /\A(?:introcv|clonecv)\z/;
5312 # Pretend these two ops do not exist. The perl parser adds them to the
5313 # beginning of any block containing my-sub declarations, whereas we handle
5314 # the subs in pad_subs and next_todo.
5315 *pp_clonecv = *pp_introcv;
5319 # For now, deparsing doesn't worry about the distinction between introcv
5320 # and clonecv, so pretend this op doesn't exist:
5327 return $self->padany($op);
5330 my %lvref_funnies = (
5331 OPpLVREF_SV, => '$',
5332 OPpLVREF_AV, => '@',
5333 OPpLVREF_HV, => '%',
5334 OPpLVREF_CV, => '&',
5338 my ($self, $op, $cx) = @_;
5340 if ($op->private & OPpLVREF_ELEM) {
5341 $left = $op->first->sibling;
5342 $left = maybe_local(@_, elem($self, $left, undef,
5343 $left->targ == OP_AELEM
5346 } elsif ($op->flags & OPf_STACKED) {
5347 $left = maybe_local(@_,
5348 $lvref_funnies{$op->private & OPpLVREF_TYPE}
5349 . $self->deparse($op->first->sibling));
5353 my $right = $self->deparse_binop_right($op, $op->first, 7);
5354 return $self->maybe_parens("\\$left = $right", $cx, 7);
5358 my ($self, $op, $cx) = @_;
5360 if ($op->private & OPpLVREF_ELEM) {
5361 $code = $op->first->name =~ /av\z/ ? &pp_aelem : &pp_helem;
5362 } elsif ($op->flags & OPf_STACKED) {
5363 $code = maybe_local(@_,
5364 $lvref_funnies{$op->private & OPpLVREF_TYPE}
5365 . $self->deparse($op->first));
5373 my ($self, $op, $cx) = @_;
5374 '\\' . ($op->last->name =~ /av\z/ ? &pp_aslice : &pp_hslice);
5378 my ($self, $op, $cx) = @_;
5379 '\\(' . ($op->flags & OPf_STACKED
5380 ? maybe_local(@_, rv2x(@_, "\@"))
5389 B::Deparse - Perl compiler backend to produce perl code
5393 B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
5394 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
5398 B::Deparse is a backend module for the Perl compiler that generates
5399 perl source code, based on the internal compiled structure that perl
5400 itself creates after parsing a program. The output of B::Deparse won't
5401 be exactly the same as the original source, since perl doesn't keep
5402 track of comments or whitespace, and there isn't a one-to-one
5403 correspondence between perl's syntactical constructions and their
5404 compiled form, but it will often be close. When you use the B<-p>
5405 option, the output also includes parentheses even when they are not
5406 required by precedence, which can make it easy to see if perl is
5407 parsing your expressions the way you intended.
5409 While B::Deparse goes to some lengths to try to figure out what your
5410 original program was doing, some parts of the language can still trip
5411 it up; it still fails even on some parts of Perl's own test suite. If
5412 you encounter a failure other than the most common ones described in
5413 the BUGS section below, you can help contribute to B::Deparse's
5414 ongoing development by submitting a bug report with a small
5419 As with all compiler backend options, these must follow directly after
5420 the '-MO=Deparse', separated by a comma but not any white space.
5426 Output data values (when they appear as constants) using Data::Dumper.
5427 Without this option, B::Deparse will use some simple routines of its
5428 own for the same purpose. Currently, Data::Dumper is better for some
5429 kinds of data (such as complex structures with sharing and
5430 self-reference) while the built-in routines are better for others
5431 (such as odd floating-point values).
5435 Normally, B::Deparse deparses the main code of a program, and all the subs
5436 defined in the same file. To include subs defined in
5437 other files, pass the B<-f> option with the filename.
5438 You can pass the B<-f> option several times, to
5439 include more than one secondary file. (Most of the time you don't want to
5440 use it at all.) You can also use this option to include subs which are
5441 defined in the scope of a B<#line> directive with two parameters.
5445 Add '#line' declarations to the output based on the line and file
5446 locations of the original code.
5450 Print extra parentheses. Without this option, B::Deparse includes
5451 parentheses in its output only when they are needed, based on the
5452 structure of your program. With B<-p>, it uses parentheses (almost)
5453 whenever they would be legal. This can be useful if you are used to
5454 LISP, or if you want to see how perl parses your input. If you say
5456 if ($var & 0x7f == 65) {print "Gimme an A!"}
5457 print ($which ? $a : $b), "\n";
5458 $name = $ENV{USER} or "Bob";
5460 C<B::Deparse,-p> will print
5463 print('Gimme an A!')
5465 (print(($which ? $a : $b)), '???');
5466 (($name = $ENV{'USER'}) or '???')
5468 which probably isn't what you intended (the C<'???'> is a sign that
5469 perl optimized away a constant value).
5473 Disable prototype checking. With this option, all function calls are
5474 deparsed as if no prototype was defined for them. In other words,
5476 perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
5485 making clear how the parameters are actually passed to C<foo>.
5489 Expand double-quoted strings into the corresponding combinations of
5490 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
5493 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
5497 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
5498 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
5500 Note that the expanded form represents the way perl handles such
5501 constructions internally -- this option actually turns off the reverse
5502 translation that B::Deparse usually does. On the other hand, note that
5503 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
5504 of $y into a string before doing the assignment.
5506 =item B<-s>I<LETTERS>
5508 Tweak the style of B::Deparse's output. The letters should follow
5509 directly after the 's', with no space or punctuation. The following
5510 options are available:
5516 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
5533 The default is not to cuddle.
5537 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
5541 Use tabs for each 8 columns of indent. The default is to use only spaces.
5542 For instance, if the style options are B<-si4T>, a line that's indented
5543 3 times will be preceded by one tab and four spaces; if the options were
5544 B<-si8T>, the same line would be preceded by three tabs.
5546 =item B<v>I<STRING>B<.>
5548 Print I<STRING> for the value of a constant that can't be determined
5549 because it was optimized away (mnemonic: this happens when a constant
5550 is used in B<v>oid context). The end of the string is marked by a period.
5551 The string should be a valid perl expression, generally a constant.
5552 Note that unless it's a number, it probably needs to be quoted, and on
5553 a command line quotes need to be protected from the shell. Some
5554 conventional values include 0, 1, 42, '', 'foo', and
5555 'Useless use of constant omitted' (which may need to be
5556 B<-sv"'Useless use of constant omitted'.">
5557 or something similar depending on your shell). The default is '???'.
5558 If you're using B::Deparse on a module or other file that's require'd,
5559 you shouldn't use a value that evaluates to false, since the customary
5560 true constant at the end of a module will be in void context when the
5561 file is compiled as a main program.
5567 Expand conventional syntax constructions into equivalent ones that expose
5568 their internal operation. I<LEVEL> should be a digit, with higher values
5569 meaning more expansion. As with B<-q>, this actually involves turning off
5570 special cases in B::Deparse's normal operations.
5572 If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
5573 while loops with continue blocks; for instance
5575 for ($i = 0; $i < 10; ++$i) {
5588 Note that in a few cases this translation can't be perfectly carried back
5589 into the source code -- if the loop's initializer declares a my variable,
5590 for instance, it won't have the correct scope outside of the loop.
5592 If I<LEVEL> is at least 5, C<use> declarations will be translated into
5593 C<BEGIN> blocks containing calls to C<require> and C<import>; for
5603 'strict'->import('refs')
5607 If I<LEVEL> is at least 7, C<if> statements will be translated into
5608 equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
5610 print 'hi' if $nice;
5622 $nice and print 'hi';
5623 $nice and do { print 'hi' };
5624 $nice ? do { print 'hi' } : do { print 'bye' };
5626 Long sequences of elsifs will turn into nested ternary operators, which
5627 B::Deparse doesn't know how to indent nicely.
5631 =head1 USING B::Deparse AS A MODULE
5636 $deparse = B::Deparse->new("-p", "-sC");
5637 $body = $deparse->coderef2text(\&func);
5638 eval "sub func $body"; # the inverse operation
5642 B::Deparse can also be used on a sub-by-sub basis from other perl
5647 $deparse = B::Deparse->new(OPTIONS)
5649 Create an object to store the state of a deparsing operation and any
5650 options. The options are the same as those that can be given on the
5651 command line (see L</OPTIONS>); options that are separated by commas
5652 after B<-MO=Deparse> should be given as separate strings.
5654 =head2 ambient_pragmas
5656 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
5658 The compilation of a subroutine can be affected by a few compiler
5659 directives, B<pragmas>. These are:
5673 Assigning to the special variable $[
5693 Ordinarily, if you use B::Deparse on a subroutine which has
5694 been compiled in the presence of one or more of these pragmas,
5695 the output will include statements to turn on the appropriate
5696 directives. So if you then compile the code returned by coderef2text,
5697 it will behave the same way as the subroutine which you deparsed.
5699 However, you may know that you intend to use the results in a
5700 particular context, where some pragmas are already in scope. In
5701 this case, you use the B<ambient_pragmas> method to describe the
5702 assumptions you wish to make.
5704 Not all of the options currently have any useful effect. See
5705 L</BUGS> for more details.
5707 The parameters it accepts are:
5713 Takes a string, possibly containing several values separated
5714 by whitespace. The special values "all" and "none" mean what you'd
5717 $deparse->ambient_pragmas(strict => 'subs refs');
5721 Takes a number, the value of the array base $[.
5722 Cannot be non-zero on Perl 5.15.3 or later.
5730 If the value is true, then the appropriate pragma is assumed to
5731 be in the ambient scope, otherwise not.
5735 Takes a string, possibly containing a whitespace-separated list of
5736 values. The values "all" and "none" are special. It's also permissible
5737 to pass an array reference here.
5739 $deparser->ambient_pragmas(re => 'eval');
5744 Takes a string, possibly containing a whitespace-separated list of
5745 values. The values "all" and "none" are special, again. It's also
5746 permissible to pass an array reference here.
5748 $deparser->ambient_pragmas(warnings => [qw[void io]]);
5750 If one of the values is the string "FATAL", then all the warnings
5751 in that list will be considered fatal, just as with the B<warnings>
5752 pragma itself. Should you need to specify that some warnings are
5753 fatal, and others are merely enabled, you can pass the B<warnings>
5756 $deparser->ambient_pragmas(
5758 warnings => [FATAL => qw/void io/],
5761 See L<warnings> for more information about lexical warnings.
5767 These two parameters are used to specify the ambient pragmas in
5768 the format used by the special variables $^H and ${^WARNING_BITS}.
5770 They exist principally so that you can write code like:
5772 { my ($hint_bits, $warning_bits);
5773 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
5774 $deparser->ambient_pragmas (
5775 hint_bits => $hint_bits,
5776 warning_bits => $warning_bits,
5780 which specifies that the ambient pragmas are exactly those which
5781 are in scope at the point of calling.
5785 This parameter is used to specify the ambient pragmas which are
5786 stored in the special hash %^H.
5792 $body = $deparse->coderef2text(\&func)
5793 $body = $deparse->coderef2text(sub ($$) { ... })
5795 Return source code for the body of a subroutine (a block, optionally
5796 preceded by a prototype in parens), given a reference to the
5797 sub. Because a subroutine can have no names, or more than one name,
5798 this method doesn't return a complete subroutine definition -- if you
5799 want to eval the result, you should prepend "sub subname ", or "sub "
5800 for an anonymous function constructor. Unless the sub was defined in
5801 the main:: package, the code will include a package declaration.
5809 In Perl 5.20 and earlier, the only pragmas to
5810 be completely supported are: C<use warnings>,
5811 C<use strict>, C<use bytes>, C<use integer>
5812 and C<use feature>. (C<$[>, which
5813 behaves like a pragma, is also supported.)
5815 Excepting those listed above, we're currently unable to guarantee that
5816 B::Deparse will produce a pragma at the correct point in the program.
5817 (Specifically, pragmas at the beginning of a block often appear right
5818 before the start of the block instead.)
5819 Since the effects of pragmas are often lexically scoped, this can mean
5820 that the pragma holds sway over a different portion of the program
5821 than in the input file.
5825 In fact, the above is a specific instance of a more general problem:
5826 we can't guarantee to produce BEGIN blocks or C<use> declarations in
5827 exactly the right place. So if you use a module which affects compilation
5828 (such as by over-riding keywords, overloading constants or whatever)
5829 then the output code might not work as intended.
5831 This is the most serious problem in Perl 5.20 and earlier. Fixing this
5832 required internal changes in Perl 5.22.
5836 Some constants don't print correctly either with or without B<-d>.
5837 For instance, neither B::Deparse nor Data::Dumper know how to print
5838 dual-valued scalars correctly, as in:
5840 use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
5842 use constant H => { "#" => 1 }; H->{"#"};
5846 An input file that uses source filtering probably won't be deparsed into
5847 runnable code, because it will still include the B<use> declaration
5848 for the source filtering module, even though the code that is
5849 produced is already ordinary Perl which shouldn't be filtered again.
5853 Optimized-away statements are rendered as
5854 '???'. This includes statements that
5855 have a compile-time side-effect, such as the obscure
5859 which is not, consequently, deparsed correctly.
5861 foreach my $i (@_) { 0 }
5863 foreach my $i (@_) { '???' }
5867 Lexical (my) variables declared in scopes external to a subroutine
5868 appear in code2ref output text as package variables. This is a tricky
5869 problem, as perl has no native facility for referring to a lexical variable
5870 defined within a different scope, although L<PadWalker> is a good start.
5872 See also L<Data::Dump::Streamer>, which combines B::Deparse and
5873 L<PadWalker> to serialize closures properly.
5877 There are probably many more bugs on non-ASCII platforms (EBCDIC).
5881 Prior to Perl 5.22, lexical C<my> subroutines were not deparsed properly.
5882 They were emitted as pure declarations, sometimes in the wrong place.
5883 Lexical C<state> subroutines were not deparsed at all.
5889 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version
5890 by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from
5891 Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
5892 Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael