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 OPpKVSLICE
17 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
18 OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST
19 OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE
20 OPpSPLIT_ASSIGN OPpSPLIT_LEX
21 OPpPADHV_ISKEYS OPpRV2HV_ISKEYS
23 OPpMULTICONCAT_APPEND OPpMULTICONCAT_STRINGIFY OPpMULTICONCAT_FAKE
24 OPpTRUEBOOL OPpINDEX_BOOLNEG
25 SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
26 SVs_PADTMP SVpad_TYPED
28 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
29 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED PMf_EXTENDED_MORE
32 MDEREF_AV_pop_rv2av_aelem
33 MDEREF_AV_gvsv_vivify_rv2av_aelem
34 MDEREF_AV_padsv_vivify_rv2av_aelem
35 MDEREF_AV_vivify_rv2av_aelem
38 MDEREF_HV_pop_rv2hv_helem
39 MDEREF_HV_gvsv_vivify_rv2hv_helem
40 MDEREF_HV_padsv_vivify_rv2hv_helem
41 MDEREF_HV_vivify_rv2hv_helem
64 # List version-specific constants here.
65 # Easiest way to keep this code portable between version looks to
66 # be to fake up a dummy constant that will never actually be true.
67 foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
68 OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE
69 PMf_CHARSET PMf_KEEPCOPY PMf_NOCAPTURE CVf_ANONCONST
70 CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
71 PMf_NONDESTRUCT OPpEVAL_BYTES
72 OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV
73 OPpLVREF_CV OPpLVREF_ELEM SVpad_STATE)) {
74 eval { B->import($_) };
76 *{$_} = sub () {0} unless *{$_}{CODE};
81 # (See also BUGS section at the end of this file)
83 # - finish tr/// changes
84 # - add option for even more parens (generalize \&foo change)
85 # - left/right context
86 # - copy comments (look at real text with $^P?)
87 # - avoid semis in one-statement blocks
88 # - associativity of &&=, ||=, ?:
89 # - ',' => '=>' (auto-unquote?)
90 # - break long lines ("\r" as discretionary break?)
91 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
92 # - more style options: brace style, hex vs. octal, quotes, ...
93 # - print big ints as hex/octal instead of decimal (heuristic?)
94 # - handle 'my $x if 0'?
95 # - version using op_next instead of op_first/sibling?
96 # - avoid string copies (pass arrays, one big join?)
99 # Current test.deparse failures
100 # comp/hints 6 - location of BEGIN blocks wrt. block openings
101 # run/switchI 1 - missing -I switches entirely
102 # perl -Ifoo -e 'print @INC'
103 # op/caller 2 - warning mask propagates backwards before warnings::register
104 # 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
105 # op/getpid 2 - can't assign to shared my() declaration (threads only)
106 # 'my $x : shared = 5'
107 # op/override 7 - parens on overridden require change v-string interpretation
108 # 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
109 # c.f. 'BEGIN { *f = sub {0} }; f 2'
110 # op/pat 774 - losing Unicode-ness of Latin1-only strings
111 # 'use charnames ":short"; $x="\N{latin:a with acute}"'
112 # op/recurse 12 - missing parens on recursive call makes it look like method
114 # op/subst 90 - inconsistent handling of utf8 under "use utf8"
115 # op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
116 # op/tiehandle compile - "use strict" deparsed in the wrong place
118 # ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
119 # ext/Data/Dumper/t/dumper compile
120 # ext/DB_file/several
122 # ext/Ernno/Errno warnings
123 # ext/IO/lib/IO/t/io_sel 23
124 # ext/PerlIO/t/encoding compile
125 # ext/POSIX/t/posix 6
126 # ext/Socket/Socket 8
127 # ext/Storable/t/croak compile
128 # lib/Attribute/Handlers/t/multi compile
129 # lib/bignum/ several
133 # lib/ExtUtils/t/bytes 4
134 # lib/File/DosGlob compile
135 # lib/Filter/Simple/t/data 1
136 # lib/Math/BigInt/t/constant 1
137 # lib/Net/t/config Deparse-warning
138 # lib/overload compile
139 # lib/Switch/ several
141 # lib/Test/Simple several
143 # lib/Tie/File/t/29_downcopy 5
149 # True when deparsing via $deparse->coderef2text; false when deparsing the
153 # (local($a), local($b)) and local($a, $b) have the same internal
154 # representation but the short form looks better. We notice we can
155 # use a large-scale local when checking the list, but need to prevent
156 # individual locals too. This hash holds the addresses of OPs that
157 # have already had their local-ness accounted for. The same thing
161 # CV for current sub (or main program) being deparsed
164 # Cached hash of lexical variables for curcv: keys are
165 # names prefixed with "m" or "o" (representing my/our), and
166 # each value is an array with two elements indicating the cop_seq
167 # of scopes in which a var of that name is valid and a third ele-
168 # ment referencing the pad name.
171 # COP for statement being deparsed
174 # name of the current package for deparsed code
177 # array of [cop_seq, CV, is_format?, name] for subs and formats we still
178 # want to deparse. The fourth element is a pad name thingy for lexical
179 # subs or a string for special blocks. For other subs, it is undef. For
180 # lexical subs, CV may be undef, indicating a stub declaration.
183 # as above, but [name, prototype] for subs that never got a GV
185 # subs_done, forms_done:
186 # keys are addresses of GVs for subs and formats we've already
187 # deparsed (or at least put into subs_todo)
190 # keys are names of subs for which we've printed declarations.
191 # That means we can omit parentheses from the arguments. It also means we
192 # need to put CORE:: on core functions of the same name.
195 # True when deparsing the replacement part of a substitution.
198 # True when deparsing the argument to \.
203 # cuddle: ' ' or '\n', depending on -sC
208 # A little explanation of how precedence contexts and associativity
211 # deparse() calls each per-op subroutine with an argument $cx (short
212 # for context, but not the same as the cx* in the perl core), which is
213 # a number describing the op's parents in terms of precedence, whether
214 # they're inside an expression or at statement level, etc. (see
215 # chart below). When ops with children call deparse on them, they pass
216 # along their precedence. Fractional values are used to implement
217 # associativity ('($x + $y) + $z' => '$x + $y + $y') and related
218 # parentheses hacks. The major disadvantage of this scheme is that
219 # it doesn't know about right sides and left sides, so say if you
220 # assign a listop to a variable, it can't tell it's allowed to leave
221 # the parens off the listop.
224 # 26 [TODO] inside interpolation context ("")
225 # 25 left terms and list operators (leftward)
229 # 21 right ! ~ \ and unary + and -
234 # 16 nonassoc named unary operators
235 # 15 nonassoc < > <= >= lt gt le ge
236 # 14 nonassoc == != <=> eq ne cmp
243 # 7 right = += -= *= etc.
245 # 5 nonassoc list operators (rightward)
249 # 1 statement modifiers
250 # 0.5 statements, but still print scopes as do { ... }
254 # Nonprinting characters with special meaning:
255 # \cS - steal parens (see maybe_parens_unop)
256 # \n - newline and indent
257 # \t - increase indent
258 # \b - decrease indent ('outdent')
259 # \f - flush left (no indent)
260 # \cK - kill following semicolon, if any
262 # Semicolon handling:
263 # - Individual statements are not deparsed with trailing semicolons.
264 # (If necessary, \cK is tacked on to the end.)
265 # - Whatever code joins statements together or emits them (lineseq,
266 # scopeop, deparse_root) is responsible for adding semicolons where
268 # - use statements are deparsed with trailing semicolons because they are
269 # immediately concatenated with the following statement.
270 # - indent() removes semicolons wherever it sees \cK.
273 BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
274 kvaslice kvhslice padsv argcheck
275 nextstate dbstate rv2av rv2hv helem custom ]) {
276 eval "sub OP_\U$_ () { " . opnumber($_) . "}"
279 # _pessimise_walk(): recursively walk the optree of a sub,
280 # possibly undoing optimisations along the way.
283 use if DEBUG, 'Data::Dumper';
285 sub _pessimise_walk {
286 my ($self, $startop) = @_;
288 return unless $$startop;
290 for ($op = $startop; $$op; $prevop = $op, $op = $op->sibling) {
291 my $ppname = $op->name;
293 # pessimisations start here
295 if ($ppname eq "padrange") {
297 # the original optimisation either (1) changed this:
298 # pushmark -> (various pad and list and null ops) -> the_rest
299 # or (2), for the = @_ case, changed this:
300 # pushmark -> gv[_] -> rv2av -> (pad stuff) -> the_rest
302 # padrange ----------------------------------------> the_rest
303 # so we just need to convert the padrange back into a
304 # pushmark, and in case (1), set its op_next to op_sibling,
305 # which is the head of the original chain of optimised-away
306 # pad ops, or for (2), set it to sibling->first, which is
307 # the original gv[_].
309 $B::overlay->{$$op} = {
312 private => ($op->private & OPpLVAL_INTRO),
316 # pessimisations end here
318 if (class($op) eq 'PMOP') {
319 if (ref($op->pmreplroot)
320 && ${$op->pmreplroot}
321 && $op->pmreplroot->isa( 'B::OP' ))
323 $self-> _pessimise_walk($op->pmreplroot);
326 # pessimise any /(?{...})/ code blocks
328 my $code_list = $op->code_list;
330 $self->_pessimise_walk($code_list);
332 elsif (${$re = $op->pmregexp} && ${$cv = $re->qr_anoncv}) {
333 $code_list = $cv->ROOT # leavesub
336 $self->_pessimise_walk($code_list);
340 if ($op->flags & OPf_KIDS) {
341 $self-> _pessimise_walk($op->first);
348 # _pessimise_walk_exe(): recursively walk the op_next chain of a sub,
349 # possibly undoing optimisations along the way.
351 sub _pessimise_walk_exe {
352 my ($self, $startop, $visited) = @_;
354 no warnings 'recursion';
356 return unless $$startop;
357 return if $visited->{$$startop};
359 for ($op = $startop; $$op; $prevop = $op, $op = $op->next) {
360 last if $visited->{$$op};
361 $visited->{$$op} = 1;
362 my $ppname = $op->name;
364 /^((and|d?or)(assign)?|(map|grep)while|range|cond_expr|once)$/
365 # entertry is also a logop, but its op_other invariably points
366 # into the same chain as the main execution path, so we skip it
368 $self->_pessimise_walk_exe($op->other, $visited);
370 elsif ($ppname eq "subst") {
371 $self->_pessimise_walk_exe($op->pmreplstart, $visited);
373 elsif ($ppname =~ /^(enter(loop|iter))$/) {
374 # redoop and nextop will already be covered by the main block
376 $self->_pessimise_walk_exe($op->lastop, $visited);
379 # pessimisations start here
383 # Go through an optree and "remove" some optimisations by using an
384 # overlay to selectively modify or un-null some ops. Deparsing in the
385 # absence of those optimisations is then easier.
387 # Note that older optimisations are not removed, as Deparse was already
388 # written to recognise them before the pessimise/overlay system was added.
391 my ($self, $root, $start) = @_;
393 no warnings 'recursion';
394 # walk tree in root-to-branch order
395 $self->_pessimise_walk($root);
398 # walk tree in execution order
399 $self->_pessimise_walk_exe($start, \%visited);
405 return class($op) eq "NULL";
409 # Add a CV to the list of subs that still need deparsing.
413 my($cv, $is_form, $name) = @_;
414 my $cvfile = $cv->FILE//'';
415 return unless ($cvfile eq $0 || exists $self->{files}{$cvfile});
417 if ($cv->OUTSIDE_SEQ) {
418 $seq = $cv->OUTSIDE_SEQ;
419 } elsif (!null($cv->START) and is_state($cv->START)) {
420 $seq = $cv->START->cop_seq;
424 my $stash = $cv->STASH;
425 if (class($stash) eq 'HV') {
426 $self->{packs}{$stash->NAME}++;
428 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form, $name];
432 # Pop the next sub from the todo list and deparse it
436 my $ent = shift @{$self->{'subs_todo'}};
437 my ($seq, $cv, $is_form, $name) = @$ent;
439 # any 'use strict; package foo' that should come before the sub
440 # declaration to sync with the first COP of the sub
442 if ($cv and !null($cv->START) and is_state($cv->START)) {
443 $pragmata = $self->pragmata($cv->START);
446 if (ref $name) { # lexical sub
449 my $flags = $name->FLAGS;
451 !$cv || $seq <= $name->COP_SEQ_RANGE_LOW
452 ? $self->keyword($flags & SVpad_OUR
454 : $flags & SVpad_STATE
458 # XXX We would do $self->keyword("sub"), but ‘my CORE::sub’
459 # doesn’t work and ‘my sub’ ignores a &sub in scope. I.e.,
460 # we have a core bug here.
461 push @text, "sub " . substr $name->PVX, 1;
464 push @text, " " . $self->deparse_sub($cv);
465 $text[-1] =~ s/ ;$/;/;
471 return $pragmata . join "", @text;
475 $name //= $self->gv_name($gv);
477 return $pragmata . $self->keyword("format") . " $name =\n"
478 . $self->deparse_format($cv). "\n";
481 if ($name eq "BEGIN") {
482 $use_dec = $self->begin_is_use($cv);
483 if (defined ($use_dec) and $self->{'expand'} < 5) {
484 return $pragmata if 0 == length($use_dec);
486 # XXX bit of a hack: Test::More's use_ok() method
487 # builds a fake use statement which deparses as, e.g.
488 # use Net::Ping (@{$args[0];});
489 # As well as being superfluous (the use_ok() is deparsed
490 # too) and ugly, it fails under use strict and otherwise
491 # makes use of a lexical var that's not in scope.
499 \s*\#line\ \d+\ \".*"\s*
506 $use_dec =~ s/^(use|no)\b/$self->keyword($1)/e;
510 if ($self->{'linenums'}) {
511 my $line = $gv->LINE;
512 my $file = $gv->FILE;
513 $l = "\n\f#line $line \"$file\"\n";
517 if (class($cv->STASH) ne "SPECIAL") {
518 $stash = $cv->STASH->NAME;
519 if ($stash ne $self->{'curstash'}) {
520 $p = $self->keyword("package") . " $stash;\n";
521 $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
522 $self->{'curstash'} = $stash;
526 return "$pragmata$p$l$use_dec";
528 if ( $name !~ /::/ and $self->lex_in_scope("&$name")
529 || $self->lex_in_scope("&$name", 1) )
531 $name = "$self->{'curstash'}::$name";
532 } elsif (defined $stash) {
533 $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
535 my $ret = "$pragmata${p}${l}" . $self->keyword("sub") . " $name "
536 . $self->deparse_sub($cv);
537 $self->{'subs_declared'}{$name} = 1;
543 # Return a "use" declaration for this BEGIN block, if appropriate
545 my ($self, $cv) = @_;
546 my $root = $cv->ROOT;
547 local @$self{qw'curcv curcvlex'} = ($cv);
548 local $B::overlay = {};
549 $self->pessimise($root, $cv->START);
551 #B::walkoptree($cv->ROOT, "debug");
552 my $lineseq = $root->first;
553 return if $lineseq->name ne "lineseq";
555 my $req_op = $lineseq->first->sibling;
556 return if $req_op->name ne "require";
558 # maybe it's C<require expr> rather than C<require 'foo'>
559 return if ($req_op->first->name ne 'const');
562 if ($req_op->first->private & OPpCONST_BARE) {
563 # Actually it should always be a bareword
564 $module = $self->const_sv($req_op->first)->PV;
565 $module =~ s[/][::]g;
569 $module = $self->const($self->const_sv($req_op->first), 6);
573 my $version_op = $req_op->sibling;
574 return if class($version_op) eq "NULL";
575 if ($version_op->name eq "lineseq") {
576 # We have a version parameter; skip nextstate & pushmark
577 my $constop = $version_op->first->next->next;
579 return unless $self->const_sv($constop)->PV eq $module;
580 $constop = $constop->sibling;
581 $version = $self->const_sv($constop);
582 if (class($version) eq "IV") {
583 $version = $version->int_value;
584 } elsif (class($version) eq "NV") {
585 $version = $version->NV;
586 } elsif (class($version) ne "PVMG") {
587 # Includes PVIV and PVNV
588 $version = $version->PV;
590 # version specified as a v-string
591 $version = 'v'.join '.', map ord, split //, $version->PV;
593 $constop = $constop->sibling;
594 return if $constop->name ne "method_named";
595 return if $self->meth_sv($constop)->PV ne "VERSION";
598 $lineseq = $version_op->sibling;
599 return if $lineseq->name ne "lineseq";
600 my $entersub = $lineseq->first->sibling;
601 if ($entersub->name eq "stub") {
602 return "use $module $version ();\n" if defined $version;
603 return "use $module ();\n";
605 return if $entersub->name ne "entersub";
607 # See if there are import arguments
610 my $svop = $entersub->first->sibling; # Skip over pushmark
611 return unless $self->const_sv($svop)->PV eq $module;
613 # Pull out the arguments
614 for ($svop=$svop->sibling; index($svop->name, "method_") != 0;
615 $svop = $svop->sibling) {
616 $args .= ", " if length($args);
617 $args .= $self->deparse($svop, 6);
621 my $method_named = $svop;
622 return if $method_named->name ne "method_named";
623 my $method_name = $self->meth_sv($method_named)->PV;
625 if ($method_name eq "unimport") {
629 # Certain pragmas are dealt with using hint bits,
630 # so we ignore them here
631 if ($module eq 'strict' || $module eq 'integer'
632 || $module eq 'bytes' || $module eq 'warnings'
633 || $module eq 'feature') {
637 if (defined $version && length $args) {
638 return "$use $module $version ($args);\n";
639 } elsif (defined $version) {
640 return "$use $module $version;\n";
641 } elsif (length $args) {
642 return "$use $module ($args);\n";
644 return "$use $module;\n";
649 my ($self, $pack, $seen) = @_;
651 if (!defined $pack) {
656 $pack =~ s/(::)?$/::/;
658 $stash = \%{"main::$pack"};
662 $INC{"overload.pm"} ? overload::StrVal($stash) : $stash
664 my $stashobj = svref_2object($stash);
665 my %stash = $stashobj->ARRAY;
666 while (my ($key, $val) = each %stash) {
667 my $flags = $val->FLAGS;
668 if ($flags & SVf_ROK) {
669 # A reference. Dump this if it is a reference to a CV. If it
670 # is a constant acting as a proxy for a full subroutine, then
671 # we may or may not have to dump it. If some form of perl-
672 # space visible code must have created it, be it a use
673 # statement, or some direct symbol-table manipulation code that
674 # we will deparse, then we don’t want to dump it. If it is the
675 # result of a declaration like sub f () { 42 } then we *do*
676 # want to dump it. The only way to distinguish these seems
677 # to be the SVs_PADTMP flag on the constant, which is admit-
679 my $class = class(my $referent = $val->RV);
680 if ($class eq "CV") {
681 $self->todo($referent, 0);
683 $class !~ /^(AV|HV|CV|FM|IO|SPECIAL)\z/
684 # A more robust way to write that would be this, but B does
685 # not provide the SVt_ constants:
686 # ($referent->FLAGS & B::SVTYPEMASK) < B::SVt_PVAV
687 and $referent->FLAGS & SVs_PADTMP
689 push @{$self->{'protos_todo'}}, [$pack . $key, $val];
691 } elsif ($flags & (SVf_POK|SVf_IOK)) {
692 # Just a prototype. As an ugly but fairly effective way
693 # to find out if it belongs here is to see if the AUTOLOAD
694 # (if any) for the stash was defined in one of our files.
695 my $A = $stash{"AUTOLOAD"};
696 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
697 && class($A->CV) eq "CV") {
699 next unless $AF eq $0 || exists $self->{'files'}{$AF};
701 push @{$self->{'protos_todo'}},
702 [$pack . $key, $flags & SVf_POK ? $val->PV: undef];
703 } elsif (class($val) eq "GV") {
704 if (class(my $cv = $val->CV) ne "SPECIAL") {
705 next if $self->{'subs_done'}{$$val}++;
707 # Ignore imposters (aliases etc)
708 my $name = $cv->NAME_HEK;
710 # avoid using $cv->GV here because if the $val GV is
711 # an alias, CvGV() could upgrade the real stash entry
713 next unless $name eq $key;
714 next unless $$stashobj == ${$cv->STASH};
717 next if $$val != ${$cv->GV};
722 if (class(my $cv = $val->FORM) ne "SPECIAL") {
723 next if $self->{'forms_done'}{$$val}++;
724 next if $$val != ${$cv->GV}; # Ignore imposters
727 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
728 $self->stash_subs($pack . $key, $seen);
738 foreach $ar (@{$self->{'protos_todo'}}) {
740 # Only print a constant if it occurs in the same package as a
741 # dumped sub. This is not perfect, but a heuristic that will
742 # hopefully work most of the time. Ideally we would use
743 # CvFILE, but a constant stub has no CvFILE.
744 my $pack = ($ar->[0] =~ /(.*)::/)[0];
745 next if $pack and !$self->{packs}{$pack}
747 my $body = defined $ar->[1]
749 ? " () {\n " . $self->const($ar->[1]->RV,0) . ";\n}"
750 : " (". $ar->[1] . ");"
752 push @ret, "sub " . $ar->[0] . "$body\n";
754 delete $self->{'protos_todo'};
762 while (length($opt = substr($opts, 0, 1))) {
764 $self->{'cuddle'} = " ";
765 $opts = substr($opts, 1);
766 } elsif ($opt eq "i") {
767 $opts =~ s/^i(\d+)//;
768 $self->{'indent_size'} = $1;
769 } elsif ($opt eq "T") {
770 $self->{'use_tabs'} = 1;
771 $opts = substr($opts, 1);
772 } elsif ($opt eq "v") {
773 $opts =~ s/^v([^.]*)(.|$)//;
774 $self->{'ex_const'} = $1;
781 my $self = bless {}, $class;
782 $self->{'cuddle'} = "\n";
783 $self->{'curcop'} = undef;
784 $self->{'curstash'} = "main";
785 $self->{'ex_const'} = "'???'";
786 $self->{'expand'} = 0;
787 $self->{'files'} = {};
788 $self->{'packs'} = {};
789 $self->{'indent_size'} = 4;
790 $self->{'linenums'} = 0;
791 $self->{'parens'} = 0;
792 $self->{'subs_todo'} = [];
793 $self->{'unquote'} = 0;
794 $self->{'use_dumper'} = 0;
795 $self->{'use_tabs'} = 0;
797 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
798 $self->{'ambient_hints'} = 0;
799 $self->{'ambient_hinthash'} = undef;
802 while (my $arg = shift @_) {
804 $self->{'use_dumper'} = 1;
805 require Data::Dumper;
806 } elsif ($arg =~ /^-f(.*)/) {
807 $self->{'files'}{$1} = 1;
808 } elsif ($arg eq "-l") {
809 $self->{'linenums'} = 1;
810 } elsif ($arg eq "-p") {
811 $self->{'parens'} = 1;
812 } elsif ($arg eq "-P") {
813 $self->{'noproto'} = 1;
814 } elsif ($arg eq "-q") {
815 $self->{'unquote'} = 1;
816 } elsif (substr($arg, 0, 2) eq "-s") {
817 $self->style_opts(substr $arg, 2);
818 } elsif ($arg =~ /^-x(\d)$/) {
819 $self->{'expand'} = $1;
826 # Mask out the bits that L<warnings::register> uses
829 $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
836 # Initialise the contextual information, either from
837 # defaults provided with the ambient_pragmas method,
838 # or from perl's own defaults otherwise.
842 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
843 ? $self->{'ambient_warnings'} & WARN_MASK
845 $self->{'hints'} = $self->{'ambient_hints'};
846 $self->{'hinthash'} = $self->{'ambient_hinthash'};
848 # also a convenient place to clear out subs_declared
849 delete $self->{'subs_declared'};
855 my $self = B::Deparse->new(@args);
856 # First deparse command-line args
857 if (defined $^I) { # deparse -i
858 print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
860 if ($^W) { # deparse -w
861 print qq(BEGIN { \$^W = $^W; }\n);
863 if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
864 my $fs = perlstring($/) || 'undef';
865 my $bs = perlstring($O::savebackslash) || 'undef';
866 print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
868 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
869 my @UNITCHECKs = B::unitcheck_av->isa("B::AV")
870 ? B::unitcheck_av->ARRAY
872 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
873 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
874 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
875 my @names = qw(BEGIN UNITCHECK CHECK INIT END);
876 my @blocks = \(@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs);
878 my ($name, $blocks) = (shift @names, shift @blocks);
879 for my $block (@$blocks) {
880 $self->todo($block, 0, $name);
884 local($SIG{"__DIE__"}) =
886 if ($self->{'curcop'}) {
887 my $cop = $self->{'curcop'};
888 my($line, $file) = ($cop->line, $cop->file);
889 print STDERR "While deparsing $file near line $line,\n";
892 $self->{'curcv'} = main_cv;
893 $self->{'curcvlex'} = undef;
894 print $self->print_protos;
895 @{$self->{'subs_todo'}} =
896 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
897 my $root = main_root;
898 local $B::overlay = {};
899 unless (null $root) {
900 $self->pad_subs($self->{'curcv'});
901 # Check for a stub-followed-by-ex-cop, resulting from a program
902 # consisting solely of sub declarations. For backward-compati-
903 # bility (and sane output) we don’t want to emit the stub.
907 # ex-nextstate (or ex-dbstate)
909 if ( $root->name eq 'leave'
910 and ($kid = $root->first)->name eq 'enter'
911 and !null($kid = $kid->sibling) and $kid->name eq 'stub'
912 and !null($kid = $kid->sibling) and $kid->name eq 'null'
913 and class($kid) eq 'COP' and null $kid->sibling )
917 $self->pessimise($root, main_start);
918 print $self->indent($self->deparse_root($root)), "\n";
922 while (scalar(@{$self->{'subs_todo'}})) {
923 push @text, $self->next_todo;
925 print $self->indent(join("", @text)), "\n" if @text;
927 # Print __DATA__ section, if necessary
929 my $laststash = defined $self->{'curcop'}
930 ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
931 if (defined *{$laststash."::DATA"}{IO}) {
932 print $self->keyword("package") . " $laststash;\n"
933 unless $laststash eq $self->{'curstash'};
934 print $self->keyword("__DATA__") . "\n";
935 print readline(*{$laststash."::DATA"});
943 croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
946 local $self->{in_coderef2text} = 1;
947 return $self->indent($self->deparse_sub(svref_2object($sub)));
950 my %strict_bits = do {
952 map +($_ => strict::bits($_)), qw/refs subs vars/
955 sub ambient_pragmas {
957 my ($hint_bits, $warning_bits, $hinthash) = (0);
963 if ($name eq 'strict') {
966 if ($val eq 'none') {
967 $hint_bits &= $strict_bits{$_} for qw/refs subs vars/;
973 @names = qw/refs subs vars/;
979 @names = split' ', $val;
981 $hint_bits |= $strict_bits{$_} for @names;
984 elsif ($name eq 'integer'
986 || $name eq 'utf8') {
989 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
992 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
996 elsif ($name eq 're') {
998 if ($val eq 'none') {
999 $hint_bits &= ~re::bits(qw/taint eval/);
1004 if ($val eq 'all') {
1005 @names = qw/taint eval/;
1011 @names = split' ',$val;
1013 $hint_bits |= re::bits(@names);
1016 elsif ($name eq 'warnings') {
1017 if ($val eq 'none') {
1018 $warning_bits = $warnings::NONE;
1027 @names = split/\s+/, $val;
1030 $warning_bits = $warnings::NONE if !defined ($warning_bits);
1031 $warning_bits |= warnings::bits(@names);
1034 elsif ($name eq 'warning_bits') {
1035 $warning_bits = $val;
1038 elsif ($name eq 'hint_bits') {
1042 elsif ($name eq '%^H') {
1047 croak "Unknown pragma type: $name";
1051 croak "The ambient_pragmas method expects an even number of args";
1054 $self->{'ambient_warnings'} = $warning_bits;
1055 $self->{'ambient_hints'} = $hint_bits;
1056 $self->{'ambient_hinthash'} = $hinthash;
1059 # This method is the inner loop, so try to keep it simple
1064 Carp::confess("Null op in deparse") if !defined($op)
1065 || class($op) eq "NULL";
1066 my $meth = "pp_" . $op->name;
1067 return $self->$meth($op, $cx);
1073 # \cK also swallows a preceding line break when followed by a
1075 $txt =~ s/\n\cK;//g;
1076 my @lines = split(/\n/, $txt);
1080 for $line (@lines) {
1081 my $cmd = substr($line, 0, 1);
1082 if ($cmd eq "\t" or $cmd eq "\b") {
1083 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
1084 if ($self->{'use_tabs'}) {
1085 $leader = "\t" x ($level / 8) . " " x ($level % 8);
1087 $leader = " " x $level;
1089 $line = substr($line, 1);
1091 if (index($line, "\f") > 0) {
1094 if (substr($line, 0, 1) eq "\f") {
1095 $line = substr($line, 1); # no indent
1097 $line = $leader . $line;
1099 $line =~ s/\cK;?//g;
1101 return join("\n", @lines);
1105 my ($self, $cv) = @_;
1106 my $padlist = $cv->PADLIST;
1107 my @names = $padlist->ARRAYelt(0)->ARRAY;
1108 my @values = $padlist->ARRAYelt(1)->ARRAY;
1111 for my $ix (0.. $#names) { for $_ ($names[$ix]) {
1112 next if class($_) eq "SPECIAL";
1114 if (defined $name && $name =~ /^&./) {
1115 my $low = $_->COP_SEQ_RANGE_LOW;
1116 my $flags = $_->FLAGS;
1117 my $outer = $flags & PADNAMEt_OUTER;
1118 if ($flags & SVpad_OUR) {
1119 push @todo, [$low, undef, 0, $_]
1120 # [seq, no cv, not format, padname]
1124 my $protocv = $flags & SVpad_STATE
1127 if (class ($protocv) ne 'CV') {
1131 while ($flags & PADNAMEt_OUTER && class ($protocv) ne 'CV')
1134 next PADENTRY if class($cv) eq 'SPECIAL'; # XXX freed?
1135 my $padlist = $cv->PADLIST;
1136 my $ix = $name->PARENT_PAD_INDEX;
1137 $name = $padlist->NAMES->ARRAYelt($ix);
1138 $flags = $name->FLAGS;
1139 $protocv = $flags & SVpad_STATE
1140 ? $padlist->ARRAYelt(1)->ARRAYelt($ix)
1144 my $defined_in_this_sub = ${$protocv->OUTSIDE} == $$cv || do {
1145 my $other = $protocv->PADLIST;
1146 $$other && $other->outid == $padlist->id;
1148 if ($flags & PADNAMEt_OUTER) {
1149 next unless $defined_in_this_sub;
1150 push @todo, [$protocv->OUTSIDE_SEQ, $protocv, 0, $_];
1153 my $outseq = $protocv->OUTSIDE_SEQ;
1154 if ($outseq <= $low) {
1155 # defined before its name is visible, so it’s gotta be
1156 # declared and defined at once: my sub foo { ... }
1157 push @todo, [$low, $protocv, 0, $_];
1160 # declared and defined separately: my sub f; sub f { ... }
1161 push @todo, [$low, undef, 0, $_];
1162 push @todo, [$outseq, $protocv, 0, $_]
1163 if $defined_in_this_sub;
1167 @{$self->{'subs_todo'}} =
1168 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo
1172 # deparse_argops(): deparse, if possible, a sequence of argcheck + argelem
1173 # ops into a subroutine signature. If successful, return the first op
1174 # following the signature ops plus the signature string; else return the
1177 # Normally a bunch of argelem ops will have been generated by the
1178 # signature parsing, but it's possible that ops have been added manually
1179 # or altered. In this case we return "()" and fall back to general
1180 # deparsing of the individual sigelems as 'my $x = $_[N]' etc.
1182 # We're only called if the top is an ex-argcheck, which is a placeholder
1183 # indicating a signature subtree.
1185 # Return a signature string, or an empty list if no deparseable as a
1188 sub deparse_argops {
1189 my ($self, $topop, $cv) = @_;
1194 $topop = $topop->first;
1195 return unless $$topop and $topop->name eq 'lineseq';
1198 # last op should be nextstate
1199 my $last = $topop->last;
1200 return unless $$last
1201 and ( _op_is_or_was($last, OP_NEXTSTATE)
1202 or _op_is_or_was($last, OP_DBSTATE));
1204 # first OP_NEXTSTATE
1206 my $o = $topop->first;
1208 return if $o->label;
1213 return unless $$o and $o->name eq 'argcheck';
1215 my ($params, $opt_params, $slurpy) = $o->aux_list($cv);
1216 my $mandatory = $params - $opt_params;
1217 my $seen_slurpy = 0;
1220 # keep looking for valid nextstate + argelem pairs, terminated
1221 # by a final nextstate
1227 # skip trailing nextstate
1228 last if $$o == $$last;
1231 return unless $o->name =~ /^(next|db)state$/;
1232 return if $o->label;
1238 if ($o->name eq 'argelem') {
1239 my $ix = $o->string($cv);
1240 while (++$last_ix < $ix) {
1241 push @sig, $last_ix < $mandatory ? '$' : '$=';
1243 my $var = $self->padname($o->targ);
1244 if ($var =~ /^[@%]/) {
1245 return if $seen_slurpy;
1247 return if $ix != $params or !$slurpy
1248 or substr($var,0,1) ne $slurpy;
1251 return if $ix >= $params;
1253 if ($o->flags & OPf_KIDS) {
1254 my $kid = $o->first;
1255 return unless $$kid and $kid->name eq 'argdefelem';
1256 my $def = $self->deparse($kid->first, 7);
1257 $def = "($def)" if $kid->first->flags & OPf_PARENS;
1262 elsif ($o->name eq 'null'
1263 and ($o->flags & OPf_KIDS)
1264 and $o->first->name eq 'argdefelem')
1266 # special case - a void context default expression: $ = expr
1268 my $defop = $o->first;
1269 my $ix = $defop->targ;
1270 while (++$last_ix < $ix) {
1271 push @sig, $last_ix < $mandatory ? '$' : '$=';
1273 return if $last_ix >= $params
1274 or $last_ix < $mandatory;
1275 my $def = $self->deparse($defop->first, 7);
1276 $def = "($def)" if $defop->first->flags & OPf_PARENS;
1277 push @sig, '$ = ' . $def;
1285 while (++$last_ix < $params) {
1286 push @sig, $last_ix < $mandatory ? '$' : '$=';
1288 push @sig, $slurpy if $slurpy and !$seen_slurpy;
1290 return (join(', ', @sig));
1294 # Deparse a sub. Returns everything except the 'sub foo',
1295 # e.g. ($$) : method { ...; }
1296 # or : prototype($$) lvalue ($a, $b) { ...; };
1305 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
1306 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
1307 local $self->{'curcop'} = $self->{'curcop'};
1309 my $has_sig = $self->{hinthash}{feature_signatures};
1310 if ($cv->FLAGS & SVf_POK) {
1311 my $myproto = $cv->PV;
1313 push @attrs, "prototype($myproto)";
1319 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ANONCONST)) {
1320 push @attrs, "lvalue" if $cv->CvFLAGS & CVf_LVALUE;
1321 push @attrs, "method" if $cv->CvFLAGS & CVf_METHOD;
1322 push @attrs, "const" if $cv->CvFLAGS & CVf_ANONCONST;
1325 local($self->{'curcv'}) = $cv;
1326 local($self->{'curcvlex'});
1327 local(@$self{qw'curstash warnings hints hinthash'})
1328 = @$self{qw'curstash warnings hints hinthash'};
1330 my $root = $cv->ROOT;
1331 local $B::overlay = {};
1332 if (not null $root) {
1333 $self->pad_subs($cv);
1334 $self->pessimise($root, $cv->START);
1335 my $lineseq = $root->first;
1337 # stub sub may have single op rather than list of ops
1338 my $is_list = ($lineseq->name eq "lineseq");
1339 my $firstop = $is_list ? $lineseq->first : $lineseq;
1341 # Try to deparse first subtree as a signature if possible.
1342 # Top of signature subtree has an ex-argcheck as a placeholder
1345 and $firstop->name eq 'null'
1346 and $firstop->targ == OP_ARGCHECK
1348 my ($mysig) = $self->deparse_argops($firstop, $cv);
1349 if (defined $mysig) {
1351 $firstop = $is_list ? $firstop->sibling : undef;
1355 if ($is_list && $firstop) {
1357 for (my $o = $firstop; $$o; $o=$o->sibling) {
1360 $body = $self->lineseq(undef, 0, @ops).";";
1361 if (!$has_sig and $ops[-1]->name =~ /^(next|db)state$/) {
1362 # this handles void context in
1363 # use feature signatures; sub ($=1) {}
1366 my $scope_en = $self->find_scope_en($lineseq);
1367 if (defined $scope_en) {
1368 my $subs = join"", $self->seq_subs($scope_en);
1369 $body .= ";\n$subs" if length($subs);
1373 $body = $self->deparse($root->first, 0);
1376 $body = ';'; # stub sub
1380 if ($self->{'linenums'}) {
1381 # a glob's gp_line is set from the line containing a
1382 # sub's closing '}' if the CV is the first use of the GV.
1383 # So make sure the linenum is set correctly for '}'
1385 my $line = $gv->LINE;
1386 my $file = $gv->FILE;
1387 $l = "\f#line $line \"$file\"\n";
1389 $body = "{\n\t$body\n$l\b}";
1392 my $sv = $cv->const_sv;
1394 # uh-oh. inlinable sub... format it differently
1395 $body = "{ " . $self->const($sv, 0) . " }\n";
1396 } else { # XSUB? (or just a declaration)
1400 $proto = defined $proto ? "($proto) " : "";
1401 $sig = defined $sig ? "($sig) " : "";
1403 $attrs = ': ' . join('', map "$_ ", @attrs) if @attrs;
1404 return "$proto$attrs$sig$body\n";
1407 sub deparse_format {
1411 local($self->{'curcv'}) = $form;
1412 local($self->{'curcvlex'});
1413 local($self->{'in_format'}) = 1;
1414 local(@$self{qw'curstash warnings hints hinthash'})
1415 = @$self{qw'curstash warnings hints hinthash'};
1416 my $op = $form->ROOT;
1417 local $B::overlay = {};
1418 $self->pessimise($op, $form->START);
1420 return "\f." if $op->first->name eq 'stub'
1421 || $op->first->name eq 'nextstate';
1422 $op = $op->first->first; # skip leavewrite, lineseq
1423 while (not null $op) {
1424 $op = $op->sibling; # skip nextstate
1426 $kid = $op->first->sibling; # skip pushmark
1427 push @text, "\f".$self->const_sv($kid)->PV;
1428 $kid = $kid->sibling;
1429 for (; not null $kid; $kid = $kid->sibling) {
1430 push @exprs, $self->deparse($kid, -1);
1431 $exprs[-1] =~ s/;\z//;
1433 push @text, "\f".join(", ", @exprs)."\n" if @exprs;
1436 return join("", @text) . "\f.";
1441 return $op->name eq "leave" || $op->name eq "scope"
1442 || $op->name eq "lineseq"
1443 || ($op->name eq "null" && class($op) eq "UNOP"
1444 && (is_scope($op->first) || $op->first->name eq "enter"));
1448 my $name = $_[0]->name;
1449 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
1452 sub is_miniwhile { # check for one-line loop ('foo() while $y--')
1454 return (!null($op) and null($op->sibling)
1455 and $op->name eq "null" and class($op) eq "UNOP"
1456 and (($op->first->name =~ /^(and|or)$/
1457 and $op->first->first->sibling->name eq "lineseq")
1458 or ($op->first->name eq "lineseq"
1459 and not null $op->first->first->sibling
1460 and $op->first->first->sibling->name eq "unstack")
1464 # Check if the op and its sibling are the initialization and the rest of a
1465 # for (..;..;..) { ... } loop
1468 # This OP might be almost anything, though it won't be a
1469 # nextstate. (It's the initialization, so in the canonical case it
1470 # will be an sassign.) The sibling is (old style) a lineseq whose
1471 # first child is a nextstate and whose second is a leaveloop, or
1472 # (new style) an unstack whose sibling is a leaveloop.
1473 my $lseq = $op->sibling;
1474 return 0 unless !is_state($op) and !null($lseq);
1475 if ($lseq->name eq "lineseq") {
1476 if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
1477 && (my $sib = $lseq->first->sibling)) {
1478 return (!null($sib) && $sib->name eq "leaveloop");
1480 } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) {
1481 my $sib = $lseq->sibling;
1482 return $sib && !null($sib) && $sib->name eq "leaveloop";
1489 return ($op->name eq "rv2sv" or
1490 $op->name eq "padsv" or
1491 $op->name eq "gv" or # only in array/hash constructs
1492 $op->flags & OPf_KIDS && !null($op->first)
1493 && $op->first->name eq "gvsv");
1498 my($text, $cx, $prec) = @_;
1499 if ($prec < $cx # unary ops nest just fine
1500 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
1501 or $self->{'parens'})
1504 # In a unop, let parent reuse our parens; see maybe_parens_unop
1505 $text = "\cS" . $text if $cx == 16;
1512 # same as above, but get around the 'if it looks like a function' rule
1513 sub maybe_parens_unop {
1515 my($name, $kid, $cx) = @_;
1516 if ($cx > 16 or $self->{'parens'}) {
1517 $kid = $self->deparse($kid, 1);
1518 if ($name eq "umask" && $kid =~ /^\d+$/) {
1519 $kid = sprintf("%#o", $kid);
1521 return $self->keyword($name) . "($kid)";
1523 $kid = $self->deparse($kid, 16);
1524 if ($name eq "umask" && $kid =~ /^\d+$/) {
1525 $kid = sprintf("%#o", $kid);
1527 $name = $self->keyword($name);
1528 if (substr($kid, 0, 1) eq "\cS") {
1530 return $name . substr($kid, 1);
1531 } elsif (substr($kid, 0, 1) eq "(") {
1532 # avoid looks-like-a-function trap with extra parens
1533 # ('+' can lead to ambiguities)
1534 return "$name(" . $kid . ")";
1536 return "$name $kid";
1541 sub maybe_parens_func {
1543 my($func, $text, $cx, $prec) = @_;
1544 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
1545 return "$func($text)";
1547 return "$func $text";
1552 my ($self, $name) = @_;
1553 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1554 my $seq = $self->{'curcop'} ? $self->{'curcop'}->cop_seq : 0;
1555 for my $a (@{$self->{'curcvlex'}{"o$name"}}) {
1556 my ($st, undef, $padname) = @$a;
1557 if ($st >= $seq && $padname->FLAGS & SVpad_TYPED) {
1558 return $padname->SvSTASH->NAME;
1566 my($op, $cx, $text) = @_;
1567 my $name = $op->name;
1568 my $our_intro = ($name =~ /^(?:(?:gv|rv2)[ash]v|split|refassign
1572 my $lval_intro = $name eq 'split' ? 0 : OPpLVAL_INTRO;
1573 # The @a in \(@a) isn't in ref context, but only when the
1575 my $need_parens = $self->{'in_refgen'} && $name =~ /[ah]v\z/
1576 && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
1577 if ((my $priv = $op->private) & ($lval_intro|$our_intro)) {
1579 push @our_local, "local" if $priv & $lval_intro;
1580 push @our_local, "our" if $priv & $our_intro;
1581 my $our_local = join " ", map $self->keyword($_), @our_local;
1582 if( $our_local[-1] eq 'our' ) {
1583 if ( $text !~ /^\W(\w+::)*\w+\z/
1584 and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
1586 die "Unexpected our($text)\n";
1588 $text =~ s/(\w+::)+//;
1590 if (my $type = $self->find_our_type($text)) {
1591 $our_local .= ' ' . $type;
1594 return $need_parens ? "($text)" : $text
1595 if $self->{'avoid_local'}{$$op};
1597 return "$our_local($text)";
1598 } elsif (want_scalar($op) || $our_local eq 'our') {
1599 return "$our_local $text";
1601 return $self->maybe_parens_func("$our_local", $text, $cx, 16);
1604 return $need_parens ? "($text)" : $text;
1610 my($op, $cx, $func, @args) = @_;
1611 if ($op->private & OPpTARGET_MY) {
1612 my $var = $self->padname($op->targ);
1613 my $val = $func->($self, $op, 7, @args);
1614 return $self->maybe_parens("$var = $val", $cx, 7);
1616 return $func->($self, $op, $cx, @args);
1623 return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
1628 my($op, $cx, $text, $padname, $forbid_parens) = @_;
1629 # The @a in \(@a) isn't in ref context, but only when the
1631 my $need_parens = !$forbid_parens && $self->{'in_refgen'}
1632 && $op->name =~ /[ah]v\z/
1633 && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
1634 # The @a in \my @a must not have parens.
1635 if (!$need_parens && $self->{'in_refgen'}) {
1638 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
1639 # Check $padname->FLAGS for statehood, rather than $op->private,
1640 # because enteriter ops do not carry the flag.
1642 $self->keyword($padname->FLAGS & SVpad_STATE ? "state" : "my");
1643 if ($padname->FLAGS & SVpad_TYPED) {
1644 $my .= ' ' . $padname->SvSTASH->NAME;
1647 return "$my($text)";
1648 } elsif ($forbid_parens || want_scalar($op)) {
1651 return $self->maybe_parens_func($my, $text, $cx, 16);
1654 return $need_parens ? "($text)" : $text;
1658 # The following OPs don't have functions:
1660 # pp_padany -- does not exist after parsing
1663 if ($AUTOLOAD =~ s/^.*::pp_//) {
1664 warn "unexpected OP_".
1665 ($_[1]->type == OP_CUSTOM ? "CUSTOM ($AUTOLOAD)" : uc $AUTOLOAD);
1668 die "Undefined subroutine $AUTOLOAD called";
1672 sub DESTROY {} # Do not AUTOLOAD
1674 # $root should be the op which represents the root of whatever
1675 # we're sequencing here. If it's undefined, then we don't append
1676 # any subroutine declarations to the deparsed ops, otherwise we
1677 # append appropriate declarations.
1679 my($self, $root, $cx, @ops) = @_;
1682 my $out_cop = $self->{'curcop'};
1683 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1685 if (defined $root) {
1686 $limit_seq = $out_seq;
1688 $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
1689 $limit_seq = $nseq if !defined($limit_seq)
1690 or defined($nseq) && $nseq < $limit_seq;
1692 $limit_seq = $self->{'limit_seq'}
1693 if defined($self->{'limit_seq'})
1694 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1695 local $self->{'limit_seq'} = $limit_seq;
1697 $self->walk_lineseq($root, \@ops,
1698 sub { push @exprs, $_[0]} );
1700 my $sep = $cx ? '; ' : ";\n";
1701 my $body = join($sep, grep {length} @exprs);
1703 if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
1704 $subs = join "\n", $self->seq_subs($limit_seq);
1706 return join($sep, grep {length} $body, $subs);
1710 my($real_block, $self, $op, $cx) = @_;
1714 local(@$self{qw'curstash warnings hints hinthash'})
1715 = @$self{qw'curstash warnings hints hinthash'} if $real_block;
1717 $kid = $op->first->sibling; # skip enter
1718 if (is_miniwhile($kid)) {
1719 my $top = $kid->first;
1720 my $name = $top->name;
1721 if ($name eq "and") {
1722 $name = $self->keyword("while");
1723 } elsif ($name eq "or") {
1724 $name = $self->keyword("until");
1725 } else { # no conditional -> while 1 or until 0
1726 return $self->deparse($top->first, 1) . " "
1727 . $self->keyword("while") . " 1";
1729 my $cond = $top->first;
1730 my $body = $cond->sibling->first; # skip lineseq
1731 $cond = $self->deparse($cond, 1);
1732 $body = $self->deparse($body, 1);
1733 return "$body $name $cond";
1738 for (; !null($kid); $kid = $kid->sibling) {
1741 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
1742 my $body = $self->lineseq($op, 0, @kids);
1743 return is_lexical_subs(@kids)
1745 : ($self->lex_in_scope("&do") ? "CORE::do" : "do")
1746 . " {\n\t$body\n\b}";
1748 my $lineseq = $self->lineseq($op, $cx, @kids);
1749 return (length ($lineseq) ? "$lineseq;" : "");
1753 sub pp_scope { scopeop(0, @_); }
1754 sub pp_lineseq { scopeop(0, @_); }
1755 sub pp_leave { scopeop(1, @_); }
1757 # This is a special case of scopeop and lineseq, for the case of the
1758 # main_root. The difference is that we print the output statements as
1759 # soon as we get them, for the sake of impatient users.
1763 local(@$self{qw'curstash warnings hints hinthash'})
1764 = @$self{qw'curstash warnings hints hinthash'};
1766 return if null $op->first; # Can happen, e.g., for Bytecode without -k
1767 for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
1770 $self->walk_lineseq($op, \@kids,
1771 sub { return unless length $_[0];
1772 print $self->indent($_[0].';');
1774 unless $_[1] == $#kids;
1779 my ($self, $op, $kids, $callback) = @_;
1781 for (my $i = 0; $i < @kids; $i++) {
1783 if (is_state $kids[$i]) {
1784 $expr = $self->deparse($kids[$i++], 0);
1786 $callback->($expr, $i);
1790 if (is_for_loop($kids[$i])) {
1791 $callback->($expr . $self->for_loop($kids[$i], 0),
1792 $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
1795 my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2);
1796 $expr2 =~ s/^sub :(?!:)/+sub :/; # statement label otherwise
1798 $callback->($expr, $i);
1802 # The BEGIN {} is used here because otherwise this code isn't executed
1803 # when you run B::Deparse on itself.
1805 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1806 "ENV", "ARGV", "ARGVOUT", "_"); }
1812 #Carp::confess() unless ref($gv) eq "B::GV";
1813 my $cv = $gv->FLAGS & SVf_ROK ? $gv->RV : 0;
1814 my $stash = ($cv || $gv)->STASH->NAME;
1816 ? $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME
1818 ? B::safename($cv->NAME_HEK || $cv->GV->NAME)
1820 if ($stash eq 'main' && $name =~ /^::/) {
1823 elsif (($stash eq 'main'
1824 && ($globalnames{$name} || $name =~ /^[^A-Za-z_:]/))
1825 or ($stash eq $self->{'curstash'} && !$globalnames{$name}
1826 && ($stash eq 'main' || $name !~ /::/))
1831 $stash = $stash . "::";
1833 if (!$raw and $name =~ /^(\^..|{)/) {
1834 $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
1836 return $stash . $name;
1839 # Return the name to use for a stash variable.
1840 # If a lexical with the same name is in scope, or
1841 # if strictures are enabled, it may need to be
1843 sub stash_variable {
1844 my ($self, $prefix, $name, $cx) = @_;
1846 return $prefix.$self->maybe_qualify($prefix, $name) if $name =~ /::/;
1848 unless ($prefix eq '$' || $prefix eq '@' || $prefix eq '&' || #'
1849 $prefix eq '%' || $prefix eq '$#') {
1850 return "$prefix$name";
1853 if ($name =~ /^[^[:alpha:]_+-]$/) {
1854 if (defined $cx && $cx == 26) {
1855 if ($prefix eq '@') {
1856 return "$prefix\{$name}";
1858 elsif ($name eq '#') { return '${#}' } # "${#}a" vs "$#a"
1860 if ($prefix eq '$#') {
1861 return "\$#{$name}";
1865 return $prefix . $self->maybe_qualify($prefix, $name);
1868 my %unctrl = # portable to EBCDIC
1870 "\c@" => '@', # unused
1897 "\c[" => '[', # unused
1898 "\c\\" => '\\', # unused
1899 "\c]" => ']', # unused
1900 "\c_" => '_', # unused
1903 # Return just the name, without the prefix. It may be returned as a quoted
1904 # string. The second return value is a boolean indicating that.
1905 sub stash_variable_name {
1906 my($self, $prefix, $gv) = @_;
1907 my $name = $self->gv_name($gv, 1);
1908 $name = $self->maybe_qualify($prefix,$name);
1909 if ($name =~ /^(?:\S|(?!\d)[\ca-\cz]?(?:\w|::)*|\d+)\z/) {
1910 $name =~ s/^([\ca-\cz])/'^' . $unctrl{$1}/e;
1911 $name =~ /^(\^..|{)/ and $name = "{$name}";
1912 return $name, 0; # not quoted
1915 single_delim("q", "'", $name, $self), 1;
1920 my ($self,$prefix,$name) = @_;
1921 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1922 if ($prefix eq "") {
1923 $name .= "::" if $name =~ /(?:\ACORE::[^:]*|::)\z/;
1926 return $name if $name =~ /::/;
1927 return $self->{'curstash'}.'::'. $name
1929 $name =~ /^(?!\d)\w/ # alphabetic
1930 && $v !~ /^\$[ab]\z/ # not $a or $b
1931 && $v =~ /\A[\$\@\%\&]/ # scalar, array, hash, or sub
1932 && !$globalnames{$name} # not a global name
1933 && $self->{hints} & $strict_bits{vars} # strict vars
1934 && !$self->lex_in_scope($v,1) # no "our"
1935 or $self->lex_in_scope($v); # conflicts with "my" variable
1940 my ($self, $name, $our) = @_;
1941 substr $name, 0, 0, = $our ? 'o' : 'm'; # our/my
1942 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1944 return 0 if !defined($self->{'curcop'});
1945 my $seq = $self->{'curcop'}->cop_seq;
1946 return 0 if !exists $self->{'curcvlex'}{$name};
1947 for my $a (@{$self->{'curcvlex'}{$name}}) {
1948 my ($st, $en) = @$a;
1949 return 1 if $seq > $st && $seq <= $en;
1954 sub populate_curcvlex {
1956 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1957 my $padlist = $cv->PADLIST;
1958 # an undef CV still in lexical chain
1959 next if class($padlist) eq "SPECIAL";
1960 my @padlist = $padlist->ARRAY;
1961 my @ns = $padlist[0]->ARRAY;
1963 for (my $i=0; $i<@ns; ++$i) {
1964 next if class($ns[$i]) eq "SPECIAL";
1965 if (class($ns[$i]) eq "PV") {
1966 # Probably that pesky lexical @_
1969 my $name = $ns[$i]->PVX;
1970 next unless defined $name;
1971 my ($seq_st, $seq_en) =
1972 ($ns[$i]->FLAGS & SVf_FAKE)
1974 : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH);
1976 push @{$self->{'curcvlex'}{
1977 ($ns[$i]->FLAGS & SVpad_OUR ? 'o' : 'm') . $name
1978 }}, [$seq_st, $seq_en, $ns[$i]];
1983 sub find_scope_st { ((find_scope(@_))[0]); }
1984 sub find_scope_en { ((find_scope(@_))[1]); }
1986 # Recurses down the tree, looking for pad variable introductions and COPs
1988 my ($self, $op, $scope_st, $scope_en) = @_;
1989 carp("Undefined op in find_scope") if !defined $op;
1990 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1993 while(my $op = shift @queue ) {
1994 for (my $o=$op->first; $$o; $o=$o->sibling) {
1995 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1996 my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW);
1997 my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH;
1998 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1999 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
2000 return ($scope_st, $scope_en);
2002 elsif (is_state($o)) {
2003 my $c = $o->cop_seq;
2004 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
2005 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
2006 return ($scope_st, $scope_en);
2008 elsif ($o->flags & OPf_KIDS) {
2009 unshift (@queue, $o);
2014 return ($scope_st, $scope_en);
2017 # Returns a list of subs which should be inserted before the COP
2019 my ($self, $op, $out_seq) = @_;
2020 my $seq = $op->cop_seq;
2021 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
2022 return $self->seq_subs($seq);
2026 my ($self, $seq) = @_;
2028 #push @text, "# ($seq)\n";
2030 return "" if !defined $seq;
2032 while (scalar(@{$self->{'subs_todo'}})
2033 and $seq > $self->{'subs_todo'}[0][0]) {
2034 my $cv = $self->{'subs_todo'}[0][1];
2035 # Skip the OUTSIDE check for lexical subs. We may be deparsing a
2036 # cloned anon sub with lexical subs declared in it, in which case
2037 # the OUTSIDE pointer points to the anon protosub.
2038 my $lexical = ref $self->{'subs_todo'}[0][3];
2039 my $outside = !$lexical && $cv && $cv->OUTSIDE;
2040 if (!$lexical and $cv
2041 and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}})
2043 push @pending, shift @{$self->{'subs_todo'}};
2046 push @text, $self->next_todo;
2048 unshift @{$self->{'subs_todo'}}, @pending;
2052 sub _features_from_bundle {
2053 my ($hints, $hh) = @_;
2054 foreach (@{$feature::feature_bundle{@feature::hint_bundles[$hints >> $feature::hint_shift]}}) {
2055 $hh->{$feature::feature{$_}} = 1;
2060 # generate any pragmas, 'package foo' etc needed to synchronise
2061 # with the given cop
2069 my $stash = $op->stashpv;
2070 if ($stash ne $self->{'curstash'}) {
2071 push @text, $self->keyword("package") . " $stash;\n";
2072 $self->{'curstash'} = $stash;
2075 my $warnings = $op->warnings;
2077 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
2078 $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
2080 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
2081 $warning_bits = $warnings::NONE;
2083 elsif ($warnings->isa("B::SPECIAL")) {
2084 $warning_bits = undef;
2087 $warning_bits = $warnings->PV & WARN_MASK;
2090 if (defined ($warning_bits) and
2091 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
2093 $self->declare_warnings($self->{'warnings'}, $warning_bits);
2094 $self->{'warnings'} = $warning_bits;
2097 my $hints = $op->hints;
2098 my $old_hints = $self->{'hints'};
2099 if ($self->{'hints'} != $hints) {
2100 push @text, $self->declare_hints($self->{'hints'}, $hints);
2101 $self->{'hints'} = $hints;
2105 $newhh = $op->hints_hash->HASH;
2108 # feature bundle hints
2109 my $from = $old_hints & $feature::hint_mask;
2110 my $to = $ hints & $feature::hint_mask;
2112 if ($to == $feature::hint_mask) {
2113 if ($self->{'hinthash'}) {
2114 delete $self->{'hinthash'}{$_}
2115 for grep /^feature_/, keys %{$self->{'hinthash'}};
2117 else { $self->{'hinthash'} = {} }
2119 = _features_from_bundle($from, $self->{'hinthash'});
2123 $feature::hint_bundles[$to >> $feature::hint_shift];
2124 $bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12
2126 $self->keyword("no") . " feature ':all';\n",
2127 $self->keyword("use") . " feature ':$bundle';\n";
2133 push @text, $self->declare_hinthash(
2134 $self->{'hinthash'}, $newhh,
2135 $self->{indent_size}, $self->{hints},
2137 $self->{'hinthash'} = $newhh;
2140 return join("", @text);
2144 # Notice how subs and formats are inserted between statements here;
2145 # also $[ assignments and pragmas.
2149 $self->{'curcop'} = $op;
2153 my @subs = $self->cop_subs($op);
2155 # Special marker to swallow up the semicolon
2160 push @text, $self->pragmata($op);
2163 # This should go after of any branches that add statements, to
2164 # increase the chances that it refers to the same line it did in
2165 # the original program.
2166 if ($self->{'linenums'} && $cx != .5) { # $cx == .5 means in a format
2167 push @text, "\f#line " . $op->line .
2168 ' "' . $op->file, qq'"\n';
2171 push @text, $op->label . ": " if $op->label;
2173 return join("", @text);
2176 sub declare_warnings {
2177 my ($self, $from, $to) = @_;
2179 my $all = (warnings::bits("all") & WARN_MASK);
2180 unless ((($from & WARN_MASK) & ~$all) =~ /[^\0]/) {
2181 # no FATAL bits need turning off
2182 if ( ($to & WARN_MASK) eq $all) {
2183 return $self->keyword("use") . " warnings;\n";
2185 elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
2186 return $self->keyword("no") . " warnings;\n";
2190 return "BEGIN {\${^WARNING_BITS} = \""
2191 . join("", map { sprintf("\\x%02x", ord $_) } split "", $to)
2196 my ($self, $from, $to) = @_;
2197 my $use = $to & ~$from;
2198 my $no = $from & ~$to;
2200 for my $pragma (hint_pragmas($use)) {
2201 $decls .= $self->keyword("use") . " $pragma;\n";
2203 for my $pragma (hint_pragmas($no)) {
2204 $decls .= $self->keyword("no") . " $pragma;\n";
2209 # Internal implementation hints that the core sets automatically, so don't need
2210 # (or want) to be passed back to the user
2211 my %ignored_hints = (
2218 'feature/bits' => 1,
2223 sub declare_hinthash {
2224 my ($self, $from, $to, $indent, $hints) = @_;
2225 my $doing_features =
2226 ($hints & $feature::hint_mask) == $feature::hint_mask;
2229 my @unfeatures; # bugs?
2230 for my $key (sort keys %$to) {
2231 next if $ignored_hints{$key};
2232 my $is_feature = $key =~ /^feature_/;
2233 next if $is_feature and not $doing_features;
2234 if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) {
2235 push(@features, $key), next if $is_feature;
2237 qq(\$^H{) . single_delim("q", "'", $key, $self) . qq(} = )
2240 ? single_delim("q", "'", $to->{$key}, $self)
2246 for my $key (sort keys %$from) {
2247 next if $ignored_hints{$key};
2248 my $is_feature = $key =~ /^feature_/;
2249 next if $is_feature and not $doing_features;
2250 if (!exists $to->{$key}) {
2251 push(@unfeatures, $key), next if $is_feature;
2252 push @decls, qq(delete \$^H{'$key'};);
2256 if (@features || @unfeatures) {
2257 if (!%rev_feature) { %rev_feature = reverse %feature::feature }
2260 push @ret, $self->keyword("use") . " feature "
2261 . join(", ", map "'$rev_feature{$_}'", @features) . ";\n";
2264 push @ret, $self->keyword("no") . " feature "
2265 . join(", ", map "'$rev_feature{$_}'", @unfeatures)
2270 join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n\cK";
2276 my (@pragmas, @strict);
2277 push @pragmas, "integer" if $bits & 0x1;
2278 for (sort keys %strict_bits) {
2279 push @strict, "'$_'" if $bits & $strict_bits{$_};
2281 if (@strict == keys %strict_bits) {
2282 push @pragmas, "strict";
2285 push @pragmas, "strict " . join ', ', @strict;
2287 push @pragmas, "bytes" if $bits & 0x8;
2291 sub pp_dbstate { pp_nextstate(@_) }
2292 sub pp_setstate { pp_nextstate(@_) }
2294 sub pp_unstack { return "" } # see also leaveloop
2296 my %feature_keywords = (
2297 # keyword => 'feature',
2302 default => 'switch',
2304 evalbytes=>'evalbytes',
2305 __SUB__ => '__SUB__',
2311 # keywords that are strong and also have a prototype
2313 my %strong_proto_keywords = map { $_ => 1 } qw(
2321 sub feature_enabled {
2322 my($self,$name) = @_;
2324 my $hints = $self->{hints} & $feature::hint_mask;
2325 if ($hints && $hints != $feature::hint_mask) {
2326 $hh = _features_from_bundle($hints);
2328 elsif ($hints) { $hh = $self->{'hinthash'} }
2329 return $hh && $hh->{"feature_$feature_keywords{$name}"}
2335 return $name if $name =~ /^CORE::/; # just in case
2336 if (exists $feature_keywords{$name}) {
2337 return "CORE::$name" if not $self->feature_enabled($name);
2339 # This sub may be called for a program that has no nextstate ops. In
2340 # that case we may have a lexical sub named no/use/sub in scope but
2341 # $self->lex_in_scope will return false because it depends on the
2342 # current nextstate op. So we need this alternate method if there is
2344 if (!$self->{'curcop'}) {
2345 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
2346 return "CORE::$name" if exists $self->{'curcvlex'}{"m&$name"}
2347 || exists $self->{'curcvlex'}{"o&$name"};
2348 } elsif ($self->lex_in_scope("&$name")
2349 || $self->lex_in_scope("&$name", 1)) {
2350 return "CORE::$name";
2352 if ($strong_proto_keywords{$name}
2353 || ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
2354 && !defined eval{prototype "CORE::$name"})
2357 exists $self->{subs_declared}{$name}
2359 exists &{"$self->{curstash}::$name"}
2361 return "CORE::$name"
2368 my($op, $cx, $name) = @_;
2369 return $self->keyword($name);
2372 sub pp_stub { "()" }
2373 sub pp_wantarray { baseop(@_, "wantarray") }
2374 sub pp_fork { baseop(@_, "fork") }
2375 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
2376 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
2377 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
2378 sub pp_tms { baseop(@_, "times") }
2379 sub pp_ghostent { baseop(@_, "gethostent") }
2380 sub pp_gnetent { baseop(@_, "getnetent") }
2381 sub pp_gprotoent { baseop(@_, "getprotoent") }
2382 sub pp_gservent { baseop(@_, "getservent") }
2383 sub pp_ehostent { baseop(@_, "endhostent") }
2384 sub pp_enetent { baseop(@_, "endnetent") }
2385 sub pp_eprotoent { baseop(@_, "endprotoent") }
2386 sub pp_eservent { baseop(@_, "endservent") }
2387 sub pp_gpwent { baseop(@_, "getpwent") }
2388 sub pp_spwent { baseop(@_, "setpwent") }
2389 sub pp_epwent { baseop(@_, "endpwent") }
2390 sub pp_ggrent { baseop(@_, "getgrent") }
2391 sub pp_sgrent { baseop(@_, "setgrent") }
2392 sub pp_egrent { baseop(@_, "endgrent") }
2393 sub pp_getlogin { baseop(@_, "getlogin") }
2395 sub POSTFIX () { 1 }
2397 # I couldn't think of a good short name, but this is the category of
2398 # symbolic unary operators with interesting precedence
2402 my($op, $cx, $name, $prec, $flags) = (@_, 0);
2403 my $kid = $op->first;
2404 $kid = $self->deparse($kid, $prec);
2405 return $self->maybe_parens(($flags & POSTFIX)
2407 # avoid confusion with filetests
2409 && $kid =~ /^[a-zA-Z](?!\w)/
2415 sub pp_preinc { pfixop(@_, "++", 23) }
2416 sub pp_predec { pfixop(@_, "--", 23) }
2417 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
2418 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
2419 sub pp_i_preinc { pfixop(@_, "++", 23) }
2420 sub pp_i_predec { pfixop(@_, "--", 23) }
2421 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
2422 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
2423 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
2424 *pp_ncomplement = *pp_complement;
2425 sub pp_scomplement { maybe_targmy(@_, \&pfixop, "~.", 21) }
2427 sub pp_negate { maybe_targmy(@_, \&real_negate) }
2431 if ($op->first->name =~ /^(i_)?negate$/) {
2433 $self->pfixop($op, $cx, "-", 21.5);
2435 $self->pfixop($op, $cx, "-", 21);
2438 sub pp_i_negate { pp_negate(@_) }
2444 $self->listop($op, $cx, "not", $op->first);
2446 $self->pfixop($op, $cx, "!", 21);
2452 my($op, $cx, $name, $nollafr) = @_;
2454 if ($op->flags & OPf_KIDS) {
2457 # this deals with 'boolkeys' right now
2458 return $self->deparse($kid,$cx);
2460 my $builtinname = $name;
2461 $builtinname =~ /^CORE::/ or $builtinname = "CORE::$name";
2462 if (defined prototype($builtinname)
2463 && $builtinname ne 'CORE::readline'
2464 && prototype($builtinname) =~ /^;?\*/
2465 && $kid->name eq "rv2gv") {
2470 if (($kid = $self->deparse($kid, 16)) !~ s/^\cS//) {
2471 # require foo() is a syntax error.
2472 $kid =~ /^(?!\d)\w/ and $kid = "($kid)";
2474 return $self->maybe_parens(
2475 $self->keyword($name) . " $kid", $cx, 16
2478 return $self->maybe_parens_unop($name, $kid, $cx);
2480 return $self->maybe_parens(
2481 $self->keyword($name) . ($op->flags & OPf_SPECIAL ? "()" : ""),
2487 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
2488 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
2489 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
2490 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
2491 sub pp_defined { unop(@_, "defined") }
2492 sub pp_undef { unop(@_, "undef") }
2493 sub pp_study { unop(@_, "study") }
2494 sub pp_ref { unop(@_, "ref") }
2495 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
2497 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
2498 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
2499 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
2500 sub pp_srand { unop(@_, "srand") }
2501 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
2502 sub pp_log { maybe_targmy(@_, \&unop, "log") }
2503 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
2504 sub pp_int { maybe_targmy(@_, \&unop, "int") }
2505 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
2506 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
2507 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
2509 sub pp_length { maybe_targmy(@_, \&unop, "length") }
2510 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
2511 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
2513 sub pp_each { unop(@_, "each") }
2514 sub pp_values { unop(@_, "values") }
2515 sub pp_keys { unop(@_, "keys") }
2516 { no strict 'refs'; *{"pp_r$_"} = *{"pp_$_"} for qw< keys each values >; }
2518 # no name because its an optimisation op that has no keyword
2521 sub pp_aeach { unop(@_, "each") }
2522 sub pp_avalues { unop(@_, "values") }
2523 sub pp_akeys { unop(@_, "keys") }
2524 sub pp_pop { unop(@_, "pop") }
2525 sub pp_shift { unop(@_, "shift") }
2527 sub pp_caller { unop(@_, "caller") }
2528 sub pp_reset { unop(@_, "reset") }
2529 sub pp_exit { unop(@_, "exit") }
2530 sub pp_prototype { unop(@_, "prototype") }
2532 sub pp_close { unop(@_, "close") }
2533 sub pp_fileno { unop(@_, "fileno") }
2534 sub pp_umask { unop(@_, "umask") }
2535 sub pp_untie { unop(@_, "untie") }
2536 sub pp_tied { unop(@_, "tied") }
2537 sub pp_dbmclose { unop(@_, "dbmclose") }
2538 sub pp_getc { unop(@_, "getc") }
2539 sub pp_eof { unop(@_, "eof") }
2540 sub pp_tell { unop(@_, "tell") }
2541 sub pp_getsockname { unop(@_, "getsockname") }
2542 sub pp_getpeername { unop(@_, "getpeername") }
2545 my ($self, $op, $cx) = @_;
2546 if (($op->flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS)) {
2547 my $kw = $self->keyword("chdir");
2548 my $kid = $self->const_sv($op->first)->PV;
2550 . ($cx >= 16 || $self->{'parens'} ? "($kid)" : " $kid");
2551 maybe_targmy(@_, sub { $_[3] }, $code);
2553 maybe_targmy(@_, \&unop, "chdir")
2557 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
2558 sub pp_readlink { unop(@_, "readlink") }
2559 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
2560 sub pp_readdir { unop(@_, "readdir") }
2561 sub pp_telldir { unop(@_, "telldir") }
2562 sub pp_rewinddir { unop(@_, "rewinddir") }
2563 sub pp_closedir { unop(@_, "closedir") }
2564 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
2565 sub pp_localtime { unop(@_, "localtime") }
2566 sub pp_gmtime { unop(@_, "gmtime") }
2567 sub pp_alarm { unop(@_, "alarm") }
2568 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
2571 my $code = unop(@_, "do", 1); # llafr does not apply
2572 if ($code =~ s/^((?:CORE::)?do) \{/$1({/) { $code .= ')' }
2578 $_[1]->private & OPpEVAL_BYTES ? 'evalbytes' : "eval"
2582 sub pp_ghbyname { unop(@_, "gethostbyname") }
2583 sub pp_gnbyname { unop(@_, "getnetbyname") }
2584 sub pp_gpbyname { unop(@_, "getprotobyname") }
2585 sub pp_shostent { unop(@_, "sethostent") }
2586 sub pp_snetent { unop(@_, "setnetent") }
2587 sub pp_sprotoent { unop(@_, "setprotoent") }
2588 sub pp_sservent { unop(@_, "setservent") }
2589 sub pp_gpwnam { unop(@_, "getpwnam") }
2590 sub pp_gpwuid { unop(@_, "getpwuid") }
2591 sub pp_ggrnam { unop(@_, "getgrnam") }
2592 sub pp_ggrgid { unop(@_, "getgrgid") }
2594 sub pp_lock { unop(@_, "lock") }
2596 sub pp_continue { unop(@_, "continue"); }
2597 sub pp_break { unop(@_, "break"); }
2601 my($op, $cx, $givwhen) = @_;
2603 my $enterop = $op->first;
2605 if ($enterop->flags & OPf_SPECIAL) {
2606 $head = $self->keyword("default");
2607 $block = $self->deparse($enterop->first, 0);
2610 my $cond = $enterop->first;
2611 my $cond_str = $self->deparse($cond, 1);
2612 $head = "$givwhen ($cond_str)";
2613 $block = $self->deparse($cond->sibling, 0);
2621 sub pp_leavegiven { givwhen(@_, $_[0]->keyword("given")); }
2622 sub pp_leavewhen { givwhen(@_, $_[0]->keyword("when")); }
2628 my $name = $self->keyword("exists");
2629 if ($op->private & OPpEXISTS_SUB) {
2630 # Checking for the existence of a subroutine
2631 return $self->maybe_parens_func($name,
2632 $self->pp_rv2cv($op->first, 16), $cx, 16);
2634 if ($op->flags & OPf_SPECIAL) {
2635 # Array element, not hash element
2636 return $self->maybe_parens_func($name,
2637 $self->pp_aelem($op->first, 16), $cx, 16);
2639 return $self->maybe_parens_func($name, $self->pp_helem($op->first, 16),
2647 my $name = $self->keyword("delete");
2648 if ($op->private & (OPpSLICE|OPpKVSLICE)) {
2649 if ($op->flags & OPf_SPECIAL) {
2650 # Deleting from an array, not a hash
2651 return $self->maybe_parens_func($name,
2652 $self->pp_aslice($op->first, 16),
2655 return $self->maybe_parens_func($name,
2656 $self->pp_hslice($op->first, 16),
2659 if ($op->flags & OPf_SPECIAL) {
2660 # Deleting from an array, not a hash
2661 return $self->maybe_parens_func($name,
2662 $self->pp_aelem($op->first, 16),
2665 return $self->maybe_parens_func($name,
2666 $self->pp_helem($op->first, 16),
2674 my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
2675 my $kid = $op->first;
2676 if ($kid->name eq 'const') {
2677 my $priv = $kid->private;
2678 my $sv = $self->const_sv($kid);
2680 if ($priv & OPpCONST_BARE) {
2684 } elsif ($priv & OPpCONST_NOVER) {
2685 $opname = $self->keyword('no');
2686 $arg = $self->const($sv, 16);
2687 } elsif ((my $tmp = $self->const($sv, 16)) =~ /^v/) {
2691 return $self->maybe_parens("$opname $arg", $cx, 16);
2697 1, # llafr does not apply
2704 my $kid = $op->first;
2705 if (not null $kid->sibling) {
2706 # XXX Was a here-doc
2707 return $self->dquote($op);
2709 $self->unop(@_, "scalar");
2716 return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
2719 sub anon_hash_or_list {
2723 my($pre, $post) = @{{"anonlist" => ["[","]"],
2724 "anonhash" => ["{","}"]}->{$op->name}};
2726 $op = $op->first->sibling; # skip pushmark
2727 for (; !null($op); $op = $op->sibling) {
2728 $expr = $self->deparse($op, 6);
2731 if ($pre eq "{" and $cx < 1) {
2732 # Disambiguate that it's not a block
2735 return $pre . join(", ", @exprs) . $post;
2741 if ($op->flags & OPf_SPECIAL) {
2742 return $self->anon_hash_or_list($op, $cx);
2744 warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL";
2748 *pp_anonhash = \&pp_anonlist;
2753 my $kid = $op->first;
2754 if ($kid->name eq "null") {
2755 my $anoncode = $kid = $kid->first;
2756 if ($anoncode->name eq "anonconst") {
2757 $anoncode = $anoncode->first->first->sibling;
2759 if ($anoncode->name eq "anoncode"
2760 or !null($anoncode = $kid->sibling) and
2761 $anoncode->name eq "anoncode") {
2762 return $self->e_anoncode({ code => $self->padval($anoncode->targ) });
2763 } elsif ($kid->name eq "pushmark") {
2764 my $sib_name = $kid->sibling->name;
2765 if ($sib_name eq 'entersub') {
2766 my $text = $self->deparse($kid->sibling, 1);
2767 # Always show parens for \(&func()), but only with -p otherwise
2768 $text = "($text)" if $self->{'parens'}
2769 or $kid->sibling->private & OPpENTERSUB_AMPER;
2774 local $self->{'in_refgen'} = 1;
2775 $self->pfixop($op, $cx, "\\", 20);
2779 my ($self, $info) = @_;
2780 my $text = $self->deparse_sub($info->{code});
2781 return $self->keyword("sub") . " $text";
2784 sub pp_srefgen { pp_refgen(@_) }
2789 my $kid = $op->first;
2791 and $op->flags & OPf_SPECIAL
2792 and $self->deparse($kid, 1) eq 'ARGV')
2796 return $self->unop($op, $cx, "readline");
2802 return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
2805 # Unary operators that can occur as pseudo-listops inside double quotes
2808 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
2810 if ($op->flags & OPf_KIDS) {
2812 # If there's more than one kid, the first is an ex-pushmark.
2813 $kid = $kid->sibling if not null $kid->sibling;
2814 return $self->maybe_parens_unop($name, $kid, $cx);
2816 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
2820 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
2821 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
2822 sub pp_uc { dq_unop(@_, "uc") }
2823 sub pp_lc { dq_unop(@_, "lc") }
2824 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
2825 sub pp_fc { dq_unop(@_, "fc") }
2829 my ($op, $cx, $name) = @_;
2830 if (class($op) eq "PVOP") {
2831 $name .= " " . $op->pv;
2832 } elsif (class($op) eq "OP") {
2834 } elsif (class($op) eq "UNOP") {
2835 (my $kid = $self->deparse($op->first, 7)) =~ s/^\cS//;
2836 # last foo() is a syntax error.
2837 $kid =~ /^(?!\d)\w/ and $kid = "($kid)";
2840 return $self->maybe_parens($name, $cx, 7);
2843 sub pp_last { loopex(@_, "last") }
2844 sub pp_next { loopex(@_, "next") }
2845 sub pp_redo { loopex(@_, "redo") }
2846 sub pp_goto { loopex(@_, "goto") }
2847 sub pp_dump { loopex(@_, "CORE::dump") }
2851 my($op, $cx, $name) = @_;
2852 if (class($op) eq "UNOP") {
2853 # Genuine '-X' filetests are exempt from the LLAFR, but not
2855 if ($name =~ /^-/) {
2856 (my $kid = $self->deparse($op->first, 16)) =~ s/^\cS//;
2857 return $self->maybe_parens("$name $kid", $cx, 16);
2859 return $self->maybe_parens_unop($name, $op->first, $cx);
2860 } elsif (class($op) =~ /^(SV|PAD)OP$/) {
2861 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
2862 } else { # I don't think baseop filetests ever survive ck_ftst, but...
2867 sub pp_lstat { ftst(@_, "lstat") }
2868 sub pp_stat { ftst(@_, "stat") }
2869 sub pp_ftrread { ftst(@_, "-R") }
2870 sub pp_ftrwrite { ftst(@_, "-W") }
2871 sub pp_ftrexec { ftst(@_, "-X") }
2872 sub pp_fteread { ftst(@_, "-r") }
2873 sub pp_ftewrite { ftst(@_, "-w") }
2874 sub pp_fteexec { ftst(@_, "-x") }
2875 sub pp_ftis { ftst(@_, "-e") }
2876 sub pp_fteowned { ftst(@_, "-O") }
2877 sub pp_ftrowned { ftst(@_, "-o") }
2878 sub pp_ftzero { ftst(@_, "-z") }
2879 sub pp_ftsize { ftst(@_, "-s") }
2880 sub pp_ftmtime { ftst(@_, "-M") }
2881 sub pp_ftatime { ftst(@_, "-A") }
2882 sub pp_ftctime { ftst(@_, "-C") }
2883 sub pp_ftsock { ftst(@_, "-S") }
2884 sub pp_ftchr { ftst(@_, "-c") }
2885 sub pp_ftblk { ftst(@_, "-b") }
2886 sub pp_ftfile { ftst(@_, "-f") }
2887 sub pp_ftdir { ftst(@_, "-d") }
2888 sub pp_ftpipe { ftst(@_, "-p") }
2889 sub pp_ftlink { ftst(@_, "-l") }
2890 sub pp_ftsuid { ftst(@_, "-u") }
2891 sub pp_ftsgid { ftst(@_, "-g") }
2892 sub pp_ftsvtx { ftst(@_, "-k") }
2893 sub pp_fttty { ftst(@_, "-t") }
2894 sub pp_fttext { ftst(@_, "-T") }
2895 sub pp_ftbinary { ftst(@_, "-B") }
2897 sub SWAP_CHILDREN () { 1 }
2898 sub ASSIGN () { 2 } # has OP= variant
2899 sub LIST_CONTEXT () { 4 } # Assignment is in list context
2905 my $name = $op->name;
2906 if ($name eq "concat" and $op->first->name eq "concat") {
2907 # avoid spurious '=' -- see comment in pp_concat
2910 if ($name eq "null" and class($op) eq "UNOP"
2911 and $op->first->name =~ /^(and|x?or)$/
2912 and null $op->first->sibling)
2914 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
2915 # with a null that's used as the common end point of the two
2916 # flows of control. For precedence purposes, ignore it.
2917 # (COND_EXPRs have these too, but we don't bother with
2918 # their associativity).
2919 return assoc_class($op->first);
2921 return $name . ($op->flags & OPf_STACKED ? "=" : "");
2924 # Left associative operators, like '+', for which
2925 # $a + $b + $c is equivalent to ($a + $b) + $c
2928 %left = ('multiply' => 19, 'i_multiply' => 19,
2929 'divide' => 19, 'i_divide' => 19,
2930 'modulo' => 19, 'i_modulo' => 19,
2932 'add' => 18, 'i_add' => 18,
2933 'subtract' => 18, 'i_subtract' => 18,
2935 'left_shift' => 17, 'right_shift' => 17,
2936 'bit_and' => 13, 'nbit_and' => 13, 'sbit_and' => 13,
2937 'bit_or' => 12, 'bit_xor' => 12,
2938 'sbit_or' => 12, 'sbit_xor' => 12,
2939 'nbit_or' => 12, 'nbit_xor' => 12,
2941 'or' => 2, 'xor' => 2,
2945 sub deparse_binop_left {
2947 my($op, $left, $prec) = @_;
2948 if ($left{assoc_class($op)} && $left{assoc_class($left)}
2949 and $left{assoc_class($op)} == $left{assoc_class($left)})
2951 return $self->deparse($left, $prec - .00001);
2953 return $self->deparse($left, $prec);
2957 # Right associative operators, like '=', for which
2958 # $a = $b = $c is equivalent to $a = ($b = $c)
2961 %right = ('pow' => 22,
2962 'sassign=' => 7, 'aassign=' => 7,
2963 'multiply=' => 7, 'i_multiply=' => 7,
2964 'divide=' => 7, 'i_divide=' => 7,
2965 'modulo=' => 7, 'i_modulo=' => 7,
2966 'repeat=' => 7, 'refassign' => 7, 'refassign=' => 7,
2967 'add=' => 7, 'i_add=' => 7,
2968 'subtract=' => 7, 'i_subtract=' => 7,
2970 'left_shift=' => 7, 'right_shift=' => 7,
2971 'bit_and=' => 7, 'sbit_and=' => 7, 'nbit_and=' => 7,
2972 'nbit_or=' => 7, 'nbit_xor=' => 7,
2973 'sbit_or=' => 7, 'sbit_xor=' => 7,
2979 sub deparse_binop_right {
2981 my($op, $right, $prec) = @_;
2982 if ($right{assoc_class($op)} && $right{assoc_class($right)}
2983 and $right{assoc_class($op)} == $right{assoc_class($right)})
2985 return $self->deparse($right, $prec - .00001);
2987 return $self->deparse($right, $prec);
2993 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
2994 my $left = $op->first;
2995 my $right = $op->last;
2997 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
3001 if ($flags & SWAP_CHILDREN) {
3002 ($left, $right) = ($right, $left);
3005 $left = $self->deparse_binop_left($op, $left, $prec);
3006 $left = "($left)" if $flags & LIST_CONTEXT
3007 and $left !~ /^(my|our|local|state|)\s*[\@%\(]/
3009 # Parenthesize if the left argument is a
3011 my $left = $leftop->first->sibling;
3012 $left->name eq 'repeat'
3013 && null($left->sibling);
3015 $right = $self->deparse_binop_right($op, $right, $prec);
3016 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
3019 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
3020 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
3021 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
3022 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
3023 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
3024 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
3025 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
3026 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
3027 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
3028 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
3029 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
3031 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
3032 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
3033 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
3034 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
3035 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
3036 *pp_nbit_and = *pp_bit_and;
3037 *pp_nbit_or = *pp_bit_or;
3038 *pp_nbit_xor = *pp_bit_xor;
3039 sub pp_sbit_and { maybe_targmy(@_, \&binop, "&.", 13, ASSIGN) }
3040 sub pp_sbit_or { maybe_targmy(@_, \&binop, "|.", 12, ASSIGN) }
3041 sub pp_sbit_xor { maybe_targmy(@_, \&binop, "^.", 12, ASSIGN) }
3043 sub pp_eq { binop(@_, "==", 14) }
3044 sub pp_ne { binop(@_, "!=", 14) }
3045 sub pp_lt { binop(@_, "<", 15) }
3046 sub pp_gt { binop(@_, ">", 15) }
3047 sub pp_ge { binop(@_, ">=", 15) }
3048 sub pp_le { binop(@_, "<=", 15) }
3049 sub pp_ncmp { binop(@_, "<=>", 14) }
3050 sub pp_i_eq { binop(@_, "==", 14) }
3051 sub pp_i_ne { binop(@_, "!=", 14) }
3052 sub pp_i_lt { binop(@_, "<", 15) }
3053 sub pp_i_gt { binop(@_, ">", 15) }
3054 sub pp_i_ge { binop(@_, ">=", 15) }
3055 sub pp_i_le { binop(@_, "<=", 15) }
3056 sub pp_i_ncmp { maybe_targmy(@_, \&binop, "<=>", 14) }
3058 sub pp_seq { binop(@_, "eq", 14) }
3059 sub pp_sne { binop(@_, "ne", 14) }
3060 sub pp_slt { binop(@_, "lt", 15) }
3061 sub pp_sgt { binop(@_, "gt", 15) }
3062 sub pp_sge { binop(@_, "ge", 15) }
3063 sub pp_sle { binop(@_, "le", 15) }
3064 sub pp_scmp { maybe_targmy(@_, \&binop, "cmp", 14) }
3066 sub pp_isa { binop(@_, "isa", 15) }
3068 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
3069 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
3072 my ($self, $op, $cx) = @_;
3073 if (($op->flags & OPf_SPECIAL) && $self->{expand} < 2) {
3074 return $self->deparse($op->last, $cx);
3077 binop(@_, "~~", 14);
3081 # '.' is special because concats-of-concats are optimized to save copying
3082 # by making all but the first concat stacked. The effect is as if the
3083 # programmer had written '($a . $b) .= $c', except legal.
3084 sub pp_concat { maybe_targmy(@_, \&real_concat) }
3088 my $left = $op->first;
3089 my $right = $op->last;
3092 if (($op->flags & OPf_STACKED) and !($op->private & OPpCONCAT_NESTED)) {
3093 # '.=' rather than optimised '.'
3097 $left = $self->deparse_binop_left($op, $left, $prec);
3098 $right = $self->deparse_binop_right($op, $right, $prec);
3099 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
3102 sub pp_repeat { maybe_targmy(@_, \&repeat) }
3104 # 'x' is weird when the left arg is a list
3108 my $left = $op->first;
3109 my $right = $op->last;
3112 if ($op->flags & OPf_STACKED) {
3116 if (null($right)) { # list repeat; count is inside left-side ex-list
3117 # in 5.21.5 and earlier
3118 my $kid = $left->first->sibling; # skip pushmark
3120 for (; !null($kid->sibling); $kid = $kid->sibling) {
3121 push @exprs, $self->deparse($kid, 6);
3124 $left = "(" . join(", ", @exprs). ")";
3126 my $dolist = $op->private & OPpREPEAT_DOLIST;
3127 $left = $self->deparse_binop_left($op, $left, $dolist ? 1 : $prec);
3132 $right = $self->deparse_binop_right($op, $right, $prec);
3133 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
3138 my ($op, $cx, $type) = @_;
3139 my $left = $op->first;
3140 my $right = $left->sibling;
3141 $left = $self->deparse($left, 9);
3142 $right = $self->deparse($right, 9);
3143 return $self->maybe_parens("$left $type $right", $cx, 9);
3149 my $flip = $op->first;
3150 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
3151 return $self->range($flip->first, $cx, $type);
3154 # one-line while/until is handled in pp_leave
3158 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
3159 my $left = $op->first;
3160 my $right = $op->first->sibling;
3161 $blockname &&= $self->keyword($blockname);
3162 if ($cx < 1 and is_scope($right) and $blockname
3163 and $self->{'expand'} < 7)
3165 $left = $self->deparse($left, 1);
3166 $right = $self->deparse($right, 0);
3167 return "$blockname ($left) {\n\t$right\n\b}\cK";
3168 } elsif ($cx < 1 and $blockname and not $self->{'parens'}
3169 and $self->{'expand'} < 7) { # $b if $a
3170 $right = $self->deparse($right, 1);
3171 $left = $self->deparse($left, 1);
3172 return "$right $blockname $left";
3173 } elsif ($cx > $lowprec and $highop) { # $a && $b
3174 $left = $self->deparse_binop_left($op, $left, $highprec);
3175 $right = $self->deparse_binop_right($op, $right, $highprec);
3176 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
3177 } else { # $a and $b
3178 $left = $self->deparse_binop_left($op, $left, $lowprec);
3179 $right = $self->deparse_binop_right($op, $right, $lowprec);
3180 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
3184 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
3185 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
3186 sub pp_dor { logop(@_, "//", 10) }
3188 # xor is syntactically a logop, but it's really a binop (contrary to
3189 # old versions of opcode.pl). Syntax is what matters here.
3190 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
3194 my ($op, $cx, $opname) = @_;
3195 my $left = $op->first;
3196 my $right = $op->first->sibling->first; # skip sassign
3197 $left = $self->deparse($left, 7);
3198 $right = $self->deparse($right, 7);
3199 return $self->maybe_parens("$left $opname $right", $cx, 7);
3202 sub pp_andassign { logassignop(@_, "&&=") }
3203 sub pp_orassign { logassignop(@_, "||=") }
3204 sub pp_dorassign { logassignop(@_, "//=") }
3206 my %cmpchain_cmpops = (
3226 sub pp_cmpchain_and {
3227 my($self, $op, $cx) = @_;
3230 my($thiscmp, $rightcond);
3231 if($op->name eq "cmpchain_and") {
3232 $thiscmp = $op->first;
3233 $rightcond = $thiscmp->sibling;
3237 my $thiscmptype = $cmpchain_cmpops{$thiscmp->name} // (return "XXX");
3239 $thiscmptype->[1] == $prec or return "XXX";
3240 $thiscmp->first->name eq "null" &&
3241 !($thiscmp->first->flags & OPf_KIDS)
3244 $prec = $thiscmptype->[1];
3245 $dep = $self->deparse($thiscmp->first, $prec);
3247 $dep .= " ".$thiscmptype->[0]." ";
3248 my $operand = $thiscmp->last;
3249 if(defined $rightcond) {
3250 $operand->name eq "cmpchain_dup" or return "XXX";
3251 $operand = $operand->first;
3253 $dep .= $self->deparse($operand, $prec);
3254 last unless defined $rightcond;
3255 if($rightcond->name eq "null" && ($rightcond->flags & OPf_KIDS) &&
3256 $rightcond->first->name eq "cmpchain_and") {
3257 $rightcond = $rightcond->first;
3261 return $self->maybe_parens($dep, $cx, $prec);
3264 sub rv2gv_or_string {
3266 if ($op->name eq "gv") { # could be open("open") or open("###")
3268 $self->stash_variable_name("", $self->gv_or_padgv($op));
3269 $quoted ? $name : "*$name";
3272 $self->deparse($op, 6);
3278 my($op, $cx, $name, $kid, $nollafr) = @_;
3280 my $parens = ($cx >= 5) || $self->{'parens'};
3281 $kid ||= $op->first->sibling;
3282 # If there are no arguments, add final parentheses (or parenthesize the
3283 # whole thing if the llafr does not apply) to account for cases like
3284 # (return)+1 or setpgrp()+1. When the llafr does not apply, we use a
3285 # precedence of 6 (< comma), as "return, 1" does not need parentheses.
3288 ? $self->maybe_parens($self->keyword($name), $cx, 7)
3289 : $self->keyword($name) . '()' x (7 < $cx);
3292 my $fullname = $self->keyword($name);
3293 my $proto = prototype("CORE::$name");
3295 ( (defined $proto && $proto =~ /^;?\*/)
3296 || $name eq 'select' # select(F) doesn't have a proto
3298 && $kid->name eq "rv2gv"
3299 && !($kid->private & OPpLVAL_INTRO)
3301 $first = $self->rv2gv_or_string($kid->first);
3304 $first = $self->deparse($kid, 6);
3306 if ($name eq "chmod" && $first =~ /^\d+$/) {
3307 $first = sprintf("%#o", $first);
3310 if not $parens and not $nollafr and substr($first, 0, 1) eq "(";
3311 push @exprs, $first;
3312 $kid = $kid->sibling;
3313 if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv"
3314 && !($kid->private & OPpLVAL_INTRO)) {
3315 push @exprs, $first = $self->rv2gv_or_string($kid->first);
3316 $kid = $kid->sibling;
3318 for (; !null($kid); $kid = $kid->sibling) {
3319 push @exprs, $self->deparse($kid, 6);
3321 if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) {
3322 return "$exprs[0] = $fullname"
3323 . ($parens ? "($exprs[0])" : " $exprs[0]");
3326 if ($parens && $nollafr) {
3327 return "($fullname " . join(", ", @exprs) . ")";
3329 return "$fullname(" . join(", ", @exprs) . ")";
3331 return "$fullname " . join(", ", @exprs);
3335 sub pp_bless { listop(@_, "bless") }
3336 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
3338 my ($self,$op,$cx) = @_;
3339 if ($op->private & OPpSUBSTR_REPL_FIRST) {
3341 listop($self, $op, 7, "substr", $op->first->sibling->sibling)
3343 . $self->deparse($op->first->sibling, 7);
3345 maybe_local(@_, listop(@_, "substr"))
3349 # Also handles pp_rindex.
3351 # The body of this function includes an unrolled maybe_targmy(),
3352 # since the two parts of that sub's actions need to have have the
3353 # '== -1' bit in between
3355 my($self, $op, $cx) = @_;
3357 my $lex = ($op->private & OPpTARGET_MY);
3358 my $bool = ($op->private & OPpTRUEBOOL);
3360 my $val = $self->listop($op, ($bool ? 14 : $lex ? 7 : $cx), $op->name);
3362 # (index() == -1) has op_eq and op_const optimised away
3364 $val .= ($op->private & OPpINDEX_BOOLNEG) ? " == -1" : " != -1";
3365 $val = "($val)" if ($op->flags & OPf_PARENS);
3368 my $var = $self->padname($op->targ);
3369 $val = $self->maybe_parens("$var = $val", $cx, 7);
3374 sub pp_rindex { pp_index(@_); }
3375 sub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) }
3376 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
3377 sub pp_formline { listop(@_, "formline") } # see also deparse_format
3378 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
3379 sub pp_unpack { listop(@_, "unpack") }
3380 sub pp_pack { listop(@_, "pack") }
3381 sub pp_join { maybe_targmy(@_, \&listop, "join") }
3382 sub pp_splice { listop(@_, "splice") }
3383 sub pp_push { maybe_targmy(@_, \&listop, "push") }
3384 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
3385 sub pp_reverse { listop(@_, "reverse") }
3386 sub pp_warn { listop(@_, "warn") }
3387 sub pp_die { listop(@_, "die") }
3388 sub pp_return { listop(@_, "return", undef, 1) } # llafr does not apply
3389 sub pp_open { listop(@_, "open") }
3390 sub pp_pipe_op { listop(@_, "pipe") }
3391 sub pp_tie { listop(@_, "tie") }
3392 sub pp_binmode { listop(@_, "binmode") }
3393 sub pp_dbmopen { listop(@_, "dbmopen") }
3394 sub pp_sselect { listop(@_, "select") }
3395 sub pp_select { listop(@_, "select") }
3396 sub pp_read { listop(@_, "read") }
3397 sub pp_sysopen { listop(@_, "sysopen") }
3398 sub pp_sysseek { listop(@_, "sysseek") }
3399 sub pp_sysread { listop(@_, "sysread") }
3400 sub pp_syswrite { listop(@_, "syswrite") }
3401 sub pp_send { listop(@_, "send") }
3402 sub pp_recv { listop(@_, "recv") }
3403 sub pp_seek { listop(@_, "seek") }
3404 sub pp_fcntl { listop(@_, "fcntl") }
3405 sub pp_ioctl { listop(@_, "ioctl") }
3406 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
3407 sub pp_socket { listop(@_, "socket") }
3408 sub pp_sockpair { listop(@_, "socketpair") }
3409 sub pp_bind { listop(@_, "bind") }
3410 sub pp_connect { listop(@_, "connect") }
3411 sub pp_listen { listop(@_, "listen") }
3412 sub pp_accept { listop(@_, "accept") }
3413 sub pp_shutdown { listop(@_, "shutdown") }
3414 sub pp_gsockopt { listop(@_, "getsockopt") }
3415 sub pp_ssockopt { listop(@_, "setsockopt") }
3416 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
3417 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
3418 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
3419 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
3420 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
3421 sub pp_link { maybe_targmy(@_, \&listop, "link") }
3422 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
3423 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
3424 sub pp_open_dir { listop(@_, "opendir") }
3425 sub pp_seekdir { listop(@_, "seekdir") }
3426 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
3427 sub pp_system { maybe_targmy(@_, \&indirop, "system") }
3428 sub pp_exec { maybe_targmy(@_, \&indirop, "exec") }
3429 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
3430 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
3431 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
3432 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
3433 sub pp_shmget { listop(@_, "shmget") }
3434 sub pp_shmctl { listop(@_, "shmctl") }
3435 sub pp_shmread { listop(@_, "shmread") }
3436 sub pp_shmwrite { listop(@_, "shmwrite") }
3437 sub pp_msgget { listop(@_, "msgget") }
3438 sub pp_msgctl { listop(@_, "msgctl") }
3439 sub pp_msgsnd { listop(@_, "msgsnd") }
3440 sub pp_msgrcv { listop(@_, "msgrcv") }
3441 sub pp_semget { listop(@_, "semget") }
3442 sub pp_semctl { listop(@_, "semctl") }
3443 sub pp_semop { listop(@_, "semop") }
3444 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
3445 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
3446 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
3447 sub pp_gsbyname { listop(@_, "getservbyname") }
3448 sub pp_gsbyport { listop(@_, "getservbyport") }
3449 sub pp_syscall { listop(@_, "syscall") }
3454 my $kid = $op->first->sibling; # skip pushmark
3456 $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
3457 my $text = $self->deparse($kid, $cx);
3458 return $cx >= 5 || $self->{'parens'}
3463 # Truncate is special because OPf_SPECIAL makes a bareword first arg
3464 # be a filehandle. This could probably be better fixed in the core
3465 # by moving the GV lookup into ck_truc.
3471 my $parens = ($cx >= 5) || $self->{'parens'};
3472 my $kid = $op->first->sibling;
3474 if ($op->flags & OPf_SPECIAL) {
3475 # $kid is an OP_CONST
3476 $fh = $self->const_sv($kid)->PV;
3478 $fh = $self->deparse($kid, 6);
3479 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
3481 my $len = $self->deparse($kid->sibling, 6);
3482 my $name = $self->keyword('truncate');
3484 return "$name($fh, $len)";
3486 return "$name $fh, $len";
3492 my($op, $cx, $name) = @_;
3494 my $firstkid = my $kid = $op->first->sibling;
3496 if ($op->flags & OPf_STACKED) {
3498 $indir = $indir->first; # skip rv2gv
3499 if (is_scope($indir)) {
3500 $indir = "{" . $self->deparse($indir, 0) . "}";
3501 $indir = "{;}" if $indir eq "{}";
3502 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
3503 $indir = $self->const_sv($indir)->PV;
3505 $indir = $self->deparse($indir, 24);
3507 $indir = $indir . " ";
3508 $kid = $kid->sibling;
3510 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
3511 $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
3514 elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
3515 $indir = '{$b cmp $a} ';
3517 for (; !null($kid); $kid = $kid->sibling) {
3518 $expr = $self->deparse($kid, !$indir && $kid == $firstkid && $name eq "sort" && $firstkid->name eq "entersub" ? 16 : 6);
3522 if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
3523 $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort');
3525 else { $name2 = $self->keyword($name) }
3526 if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
3527 return "$exprs[0] = $name2 $indir $exprs[0]";
3530 my $args = $indir . join(", ", @exprs);
3531 if ($indir ne "" && $name eq "sort") {
3532 # We don't want to say "sort(f 1, 2, 3)", since perl -w will
3533 # give bareword warnings in that case. Therefore if context
3534 # requires, we'll put parens around the outside "(sort f 1, 2,
3535 # 3)". Unfortunately, we'll currently think the parens are
3536 # necessary more often that they really are, because we don't
3537 # distinguish which side of an assignment we're on.
3539 return "($name2 $args)";
3541 return "$name2 $args";
3544 !$indir && $name eq "sort"
3545 && !null($op->first->sibling)
3546 && $op->first->sibling->name eq 'entersub'
3548 # We cannot say sort foo(bar), as foo will be interpreted as a
3549 # comparison routine. We have to say sort(...) in that case.
3550 return "$name2($args)";
3553 ? $self->maybe_parens_func($name2, $args, $cx, 5)
3554 : $name2 . '()' x (7 < $cx);
3559 sub pp_prtf { indirop(@_, "printf") }
3560 sub pp_print { indirop(@_, "print") }
3561 sub pp_say { indirop(@_, "say") }
3562 sub pp_sort { indirop(@_, "sort") }
3566 my($op, $cx, $name) = @_;
3568 my $kid = $op->first; # this is the (map|grep)start
3569 $kid = $kid->first->sibling; # skip a pushmark
3570 my $code = $kid->first; # skip a null
3571 if (is_scope $code) {
3572 $code = "{" . $self->deparse($code, 0) . "} ";
3574 $code = $self->deparse($code, 24);
3575 $code .= ", " if !null($kid->sibling);
3577 $kid = $kid->sibling;
3578 for (; !null($kid); $kid = $kid->sibling) {
3579 $expr = $self->deparse($kid, 6);
3580 push @exprs, $expr if defined $expr;
3582 return $self->maybe_parens_func($self->keyword($name),
3583 $code . join(", ", @exprs), $cx, 5);
3586 sub pp_mapwhile { mapop(@_, "map") }
3587 sub pp_grepwhile { mapop(@_, "grep") }
3588 sub pp_mapstart { baseop(@_, "map") }
3589 sub pp_grepstart { baseop(@_, "grep") }
3594 eval { require B::Op_private }
3595 ? @{$B::Op_private::ops_using{OPpLVAL_INTRO}}
3596 : qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice
3597 hslice delete padsv padav padhv enteriter entersub padrange
3598 pushmark cond_expr refassign list)
3600 delete @uses_intro{qw( lvref lvrefslice lvavref entersub )};
3604 # Look for a my/state attribute declaration in a list or ex-list.
3605 # Returns undef if not found, 'my($x, @a) :Foo(bar)' etc otherwise.
3607 # There are three basic tree structs that are expected:
3610 # <1> ex-list vK/LVINTRO ->c
3611 # <0> ex-pushmark v ->3
3612 # <1> entersub[t2] vKRS*/TARG ->b
3614 # <0> padsv[$x:64,65] vM/LVINTRO ->c
3619 # <1> ex-list vK ->c
3620 # <0> ex-pushmark v ->3
3621 # <0> padav[@a:64,65] vM/LVINTRO ->4
3622 # <1> entersub[t2] vKRS*/TARG ->c
3625 # my ($x,@a,%h) :foo;
3627 # <;> nextstate(main 64 -e:1) v:{ ->3
3629 # <0> pushmark vM/LVINTRO ->4
3630 # <0> padsv[$x:64,65] vM/LVINTRO ->5
3631 # <0> padav[@a:64,65] vM/LVINTRO ->6
3632 # <0> padhv[%h:64,65] vM/LVINTRO ->7
3633 # <1> entersub[t4] vKRS*/TARG ->f
3635 # <1> entersub[t5] vKRS*/TARG ->n
3637 # <1> entersub[t6] vKRS*/TARG ->v
3639 # where the entersub in all cases looks like
3640 # <1> entersub[t2] vKRS*/TARG ->c
3641 # <0> pushmark s ->5
3642 # <$> const[PV "attributes"] sM ->6
3643 # <$> const[PV "main"] sM ->7
3644 # <1> srefgen sKM/1 ->9
3645 # <1> ex-list lKRM ->8
3646 # <0> padsv[@a:64,65] sRM ->8
3647 # <$> const[PV "foo"] sM ->a
3648 # <.> method_named[PV "import"] ->b
3650 sub maybe_var_attr {
3651 my ($self, $op, $cx) = @_;
3653 my $kid = $op->first->sibling; # skip pushmark
3654 return if class($kid) eq 'NULL';
3659 # Extract out all the pad ops and entersub ops into
3660 # @padops and @entersubops. Return if anything else seen.
3661 # Also determine what class (if any) all the pad vars belong to
3663 my $decl; # 'my' or 'state'
3664 my (@padops, @entersubops);
3665 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
3666 my $lopname = $lop->name;
3667 my $loppriv = $lop->private;
3668 if ($lopname =~ /^pad[sah]v$/) {
3669 return unless $loppriv & OPpLVAL_INTRO;
3671 my $padname = $self->padname_sv($lop->targ);
3672 my $thisclass = ($padname->FLAGS & SVpad_TYPED)
3673 ? $padname->SvSTASH->NAME : 'main';
3675 # all pad vars must be in the same class
3676 $class //= $thisclass;
3677 return unless $thisclass eq $class;
3679 # all pad vars must be the same sort of declaration
3680 # (all my, all state, etc)
3681 my $this = ($loppriv & OPpPAD_STATE) ? 'state' : 'my';
3682 if (defined $decl) {
3683 return unless $this eq $decl;
3689 elsif ($lopname eq 'entersub') {
3690 push @entersubops, $lop;
3697 return unless @padops && @padops == @entersubops;
3699 # there should be a balance: each padop has a corresponding
3700 # 'attributes'->import() method call, in the same order.
3705 for my $i (0..$#padops) {
3706 my $padop = $padops[$i];
3707 my $esop = $entersubops[$i];
3709 push @varnames, $self->padname($padop->targ);
3711 return unless ($esop->flags & OPf_KIDS);
3713 my $kid = $esop->first;
3714 return unless $kid->type == OP_PUSHMARK;
3716 $kid = $kid->sibling;
3717 return unless $$kid && $kid->type == OP_CONST;
3718 return unless $self->const_sv($kid)->PV eq 'attributes';
3720 $kid = $kid->sibling;
3721 return unless $$kid && $kid->type == OP_CONST; # __PACKAGE__
3723 $kid = $kid->sibling;
3725 && $kid->name eq "srefgen"
3726 && ($kid->flags & OPf_KIDS)
3727 && ($kid->first->flags & OPf_KIDS)
3728 && $kid->first->first->name =~ /^pad[sah]v$/
3729 && $kid->first->first->targ == $padop->targ;
3731 $kid = $kid->sibling;
3734 last if ($kid->type != OP_CONST);
3735 push @attr, $self->const_sv($kid)->PV;
3736 $kid = $kid->sibling;
3738 return unless @attr;
3739 my $thisattr = ":" . join(' ', @attr);
3740 $attr_text //= $thisattr;
3741 # all import calls must have the same list of attributes
3742 return unless $attr_text eq $thisattr;
3744 return unless $kid->name eq 'method_named';
3745 return unless $self->meth_sv($kid)->PV eq 'import';
3747 $kid = $kid->sibling;
3752 $res .= " $class " if $class ne 'main';
3755 ? "(" . join(', ', @varnames) . ')'
3758 return "$res $attr_text";
3767 # might be my ($s,@a,%h) :Foo(bar);
3768 my $my_attr = maybe_var_attr($self, $op, $cx);
3769 return $my_attr if defined $my_attr;
3773 my $kid = $op->first->sibling; # skip pushmark
3774 return '' if class($kid) eq 'NULL';
3776 my $local = "either"; # could be local(...), my(...), state(...) or our(...)
3778 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
3779 my $lopname = $lop->name;
3780 my $loppriv = $lop->private;
3782 if ($lopname =~ /^pad[ash]v$/ && $loppriv & OPpLVAL_INTRO) {
3783 if ($loppriv & OPpPAD_STATE) { # state()
3784 ($local = "", last) if $local !~ /^(?:either|state)$/;
3787 ($local = "", last) if $local !~ /^(?:either|my)$/;
3790 my $padname = $self->padname_sv($lop->targ);
3791 if ($padname->FLAGS & SVpad_TYPED) {
3792 $newtype = $padname->SvSTASH->NAME;
3794 } elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/
3795 && $loppriv & OPpOUR_INTRO
3796 or $lopname eq "null" && class($lop) eq 'UNOP'
3797 && $lop->first->name eq "gvsv"
3798 && $lop->first->private & OPpOUR_INTRO) { # our()
3799 my $newlocal = "local " x !!($loppriv & OPpLVAL_INTRO) . "our";
3801 if $local ne 'either' && $local ne $newlocal;
3803 my $funny = !$1 || $1 eq 's' ? '$' : $1 eq 'a' ? '@' : '%';
3804 if (my $t = $self->find_our_type(
3805 $funny . $self->gv_or_padgv($lop->first)->NAME
3809 } elsif ($lopname ne 'undef'
3810 and !($loppriv & OPpLVAL_INTRO)
3811 || !exists $uses_intro{$lopname eq 'null'
3812 ? substr B::ppname($lop->targ), 3
3815 $local = ""; # or not
3817 } elsif ($lopname ne "undef")
3820 ($local = "", last) if $local !~ /^(?:either|local)$/;
3823 if (defined $type && defined $newtype && $newtype ne $type) {
3829 $local = "" if $local eq "either"; # no point if it's all undefs
3830 $local &&= join ' ', map $self->keyword($_), split / /, $local;
3831 $local .= " $type " if $local && length $type;
3832 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
3833 for (; !null($kid); $kid = $kid->sibling) {
3835 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
3840 $self->{'avoid_local'}{$$lop}++;
3841 $expr = $self->deparse($kid, 6);
3842 delete $self->{'avoid_local'}{$$lop};
3844 $expr = $self->deparse($kid, 6);
3849 if (@exprs == 1 && ($local eq 'state' || $local eq 'CORE::state')) {
3850 # 'state @a = ...' is legal, while 'state(@a) = ...' currently isn't
3851 return "$local $exprs[0]";
3853 return "$local(" . join(", ", @exprs) . ")";
3855 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
3859 sub is_ifelse_cont {
3861 return ($op->name eq "null" and class($op) eq "UNOP"
3862 and $op->first->name =~ /^(and|cond_expr)$/
3863 and is_scope($op->first->first->sibling));
3869 my $cond = $op->first;
3870 my $true = $cond->sibling;
3871 my $false = $true->sibling;
3872 my $cuddle = $self->{'cuddle'};
3873 unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
3874 (is_scope($false) || is_ifelse_cont($false))
3875 and $self->{'expand'} < 7) {
3876 $cond = $self->deparse($cond, 8);
3877 $true = $self->deparse($true, 6);
3878 $false = $self->deparse($false, 8);
3879 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
3882 $cond = $self->deparse($cond, 1);
3883 $true = $self->deparse($true, 0);
3884 my $head = $self->keyword("if") . " ($cond) {\n\t$true\n\b}";
3887 while (!null($false) and is_ifelse_cont($false)) {
3888 my $newop = $false->first;
3889 my $newcond = $newop->first;
3890 my $newtrue = $newcond->sibling;
3891 $false = $newtrue->sibling; # last in chain is OP_AND => no else
3892 if ($newcond->name eq "lineseq")
3894 # lineseq to ensure correct line numbers in elsif()
3895 # Bug #37302 fixed by change #33710.
3896 $newcond = $newcond->first->sibling;
3898 $newcond = $self->deparse($newcond, 1);
3899 $newtrue = $self->deparse($newtrue, 0);
3900 $elsif ||= $self->keyword("elsif");
3901 push @elsifs, "$elsif ($newcond) {\n\t$newtrue\n\b}";
3903 if (!null($false)) {
3904 $false = $cuddle . $self->keyword("else") . " {\n\t" .
3905 $self->deparse($false, 0) . "\n\b}\cK";
3909 return $head . join($cuddle, "", @elsifs) . $false;
3913 my ($self, $op, $cx) = @_;
3914 my $cond = $op->first;
3915 my $true = $cond->sibling;
3917 my $ret = $self->deparse($true, $cx);
3918 $ret =~ s/^(\(?)\$/$1 . $self->keyword("state") . ' $'/e;
3924 my($op, $cx, $init) = @_;
3925 my $enter = $op->first;
3926 my $kid = $enter->sibling;
3927 local(@$self{qw'curstash warnings hints hinthash'})
3928 = @$self{qw'curstash warnings hints hinthash'};
3934 if ($kid->name eq "lineseq") { # bare or infinite loop
3935 if ($kid->last->name eq "unstack") { # infinite
3936 $head = "while (1) "; # Can't use for(;;) if there's a continue
3942 } elsif ($enter->name eq "enteriter") { # foreach
3943 my $ary = $enter->first->sibling; # first was pushmark
3944 my $var = $ary->sibling;
3945 if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
3946 # "reverse" was optimised away
3947 $ary = listop($self, $ary->first->sibling, 1, 'reverse');
3948 } elsif ($enter->flags & OPf_STACKED
3949 and not null $ary->first->sibling->sibling)
3951 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
3952 $self->deparse($ary->first->sibling->sibling, 9);
3954 $ary = $self->deparse($ary, 1);
3957 $var = $self->pp_padsv($enter, 1, 1);
3958 } elsif ($var->name eq "rv2gv") {
3959 $var = $self->pp_rv2sv($var, 1);
3960 if ($enter->private & OPpOUR_INTRO) {
3961 # our declarations don't have package names
3962 $var =~ s/^(.).*::/$1/;
3965 } elsif ($var->name eq "gv") {
3966 $var = "\$" . $self->deparse($var, 1);
3968 $var = $self->deparse($var, 1);
3970 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
3971 if (!is_state $body->first and $body->first->name !~ /^(?:stub|leave|scope)$/) {
3972 confess unless $var eq '$_';
3973 $body = $body->first;
3974 return $self->deparse($body, 2) . " "
3975 . $self->keyword("foreach") . " ($ary)";
3977 $head = "foreach $var ($ary) ";
3978 } elsif ($kid->name eq "null") { # while/until
3980 $name = {"and" => "while", "or" => "until"}->{$kid->name};
3981 $cond = $kid->first;
3982 $body = $kid->first->sibling;
3983 } elsif ($kid->name eq "stub") { # bare and empty
3984 return "{;}"; # {} could be a hashref
3986 # If there isn't a continue block, then the next pointer for the loop
3987 # will point to the unstack, which is kid's last child, except
3988 # in a bare loop, when it will point to the leaveloop. When neither of
3989 # these conditions hold, then the second-to-last child is the continue
3990 # block (or the last in a bare loop).
3991 my $cont_start = $enter->nextop;
3995 if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
3997 $cont = $body->last;
3999 $cont = $body->first;
4000 while (!null($cont->sibling->sibling)) {
4001 $cont = $cont->sibling;
4004 my $state = $body->first;
4005 my $cuddle = $self->{'cuddle'};
4007 for (; $$state != $$cont; $state = $state->sibling) {
4008 push @states, $state;
4010 $body = $self->lineseq(undef, 0, @states);
4011 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
4012 $precond = "for ($init; ";
4013 $postcond = "; " . $self->deparse($cont, 1) .") ";
4016 $cont = $cuddle . "continue {\n\t" .
4017 $self->deparse($cont, 0) . "\n\b}\cK";
4020 return "" if !defined $body;
4022 $precond = "for ($init; ";
4026 $body = $self->deparse($body, 0);
4028 if ($precond) { # for(;;)
4029 $cond &&= $name eq 'until'
4030 ? listop($self, undef, 1, "not", $cond->first)
4031 : $self->deparse($cond, 1);
4032 $head = "$precond$cond$postcond";
4034 if ($name && !$head) {
4035 ref $cond and $cond = $self->deparse($cond, 1);
4036 $head = "$name ($cond) ";
4038 $head =~ s/^(for(?:each)?|while|until)/$self->keyword($1)/e;
4039 $body =~ s/;?$/;\n/;
4041 return $head . "{\n\t" . $body . "\b}" . $cont;
4044 sub pp_leaveloop { shift->loop_common(@_, "") }
4049 my $init = $self->deparse($op, 1);
4050 my $s = $op->sibling;
4051 my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling;
4052 return $self->loop_common($ll, $cx, $init);
4057 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
4061 my ($op, $expect_type) = @_;
4062 my $type = $op->type;
4063 return($type == $expect_type
4064 || ($type == OP_NULL && $op->targ == $expect_type));
4068 my($self, $op, $cx) = @_;
4070 # might be 'my $s :Foo(bar);'
4071 if ($op->targ == OP_LIST) {
4072 my $my_attr = maybe_var_attr($self, $op, $cx);
4073 return $my_attr if defined $my_attr;
4076 if (class($op) eq "OP") {
4078 return $self->{'ex_const'} if $op->targ == OP_CONST;
4079 } elsif (class ($op) eq "COP") {
4080 return &pp_nextstate;
4081 } elsif ($op->first->name eq 'pushmark'
4082 or $op->first->name eq 'null'
4083 && $op->first->targ == OP_PUSHMARK
4084 && _op_is_or_was($op, OP_LIST)) {
4085 return $self->pp_list($op, $cx);
4086 } elsif ($op->first->name eq "enter") {
4087 return $self->pp_leave($op, $cx);
4088 } elsif ($op->first->name eq "leave") {
4089 return $self->pp_leave($op->first, $cx);
4090 } elsif ($op->first->name eq "scope") {
4091 return $self->pp_scope($op->first, $cx);
4092 } elsif ($op->targ == OP_STRINGIFY) {
4093 return $self->dquote($op, $cx);
4094 } elsif ($op->targ == OP_GLOB) {
4095 return $self->pp_glob(
4096 $op->first # entersub
4102 } elsif (!null($op->first->sibling) and
4103 $op->first->sibling->name eq "readline" and
4104 $op->first->sibling->flags & OPf_STACKED) {
4105 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
4106 . $self->deparse($op->first->sibling, 7),
4108 } elsif (!null($op->first->sibling) and
4109 $op->first->sibling->name =~ /^transr?\z/ and
4110 $op->first->sibling->flags & OPf_STACKED) {
4111 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
4112 . $self->deparse($op->first->sibling, 20),
4114 } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
4115 return ($self->lex_in_scope("&do") ? "CORE::do" : "do")
4116 . " {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
4117 } elsif (!null($op->first->sibling) and
4118 $op->first->sibling->name eq "null" and
4119 class($op->first->sibling) eq "UNOP" and
4120 $op->first->sibling->first->flags & OPf_STACKED and
4121 $op->first->sibling->first->name eq "rcatline") {
4122 return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
4123 . $self->deparse($op->first->sibling, 18),
4126 return $self->deparse($op->first, $cx);
4133 return $self->padname_sv($targ)->PVX;
4139 return substr($self->padname($op->targ), 1); # skip $/@/%
4144 my($op, $cx, $forbid_parens) = @_;
4145 my $targ = $op->targ;
4146 return $self->maybe_my($op, $cx, $self->padname($targ),
4147 $self->padname_sv($targ),
4151 sub pp_padav { pp_padsv(@_) }
4153 # prepend 'keys' where its been optimised away, with suitable handling
4154 # of CORE:: and parens
4156 sub add_keys_keyword {
4157 my ($self, $str, $cx) = @_;
4158 $str = $self->maybe_parens($str, $cx, 16);
4159 # 'keys %h' versus 'keys(%h)'
4160 $str = " $str" unless $str =~ /^\(/;
4161 return $self->keyword("keys") . $str;
4165 my ($self, $op, $cx) = @_;
4166 my $str = pp_padsv(@_);
4167 # with OPpPADHV_ISKEYS the keys op is optimised away, except
4168 # in scalar context the old op is kept (but not executed) so its targ
4170 if ( ($op->private & OPpPADHV_ISKEYS)
4171 && !(($op->flags & OPf_WANT) == OPf_WANT_SCALAR))
4173 $str = $self->add_keys_keyword($str, $cx);
4181 if (class($op) eq "PADOP") {
4182 return $self->padval($op->padix);
4183 } else { # class($op) eq "SVOP"
4191 my $gv = $self->gv_or_padgv($op);
4192 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
4193 $self->gv_name($gv), $cx));
4199 my $gv = $self->gv_or_padgv($op);
4200 return $self->maybe_qualify("", $self->gv_name($gv));
4203 sub pp_aelemfast_lex {
4206 my $name = $self->padname($op->targ);
4208 my $i = $op->private;
4209 $i -= 256 if $i > 127;
4210 return $name . "[$i]";
4216 # optimised PADAV, pre 5.15
4217 return $self->pp_aelemfast_lex(@_) if ($op->flags & OPf_SPECIAL);
4219 my $gv = $self->gv_or_padgv($op);
4220 my($name,$quoted) = $self->stash_variable_name('@',$gv);
4221 $name = $quoted ? "$name->" : '$' . $name;
4222 my $i = $op->private;
4223 $i -= 256 if $i > 127;
4224 return $name . "[$i]";
4229 my($op, $cx, $type) = @_;
4231 if (class($op) eq 'NULL' || !$op->can("first")) {
4232 carp("Unexpected op in pp_rv2x");
4235 my $kid = $op->first;
4236 if ($kid->name eq "gv") {
4237 return $self->stash_variable($type,
4238 $self->gv_name($self->gv_or_padgv($kid)), $cx);
4239 } elsif (is_scalar $kid) {
4240 my $str = $self->deparse($kid, 0);
4241 if ($str =~ /^\$([^\w\d])\z/) {
4242 # "$$+" isn't a legal way to write the scalar dereference
4243 # of $+, since the lexer can't tell you aren't trying to
4244 # do something like "$$ + 1" to get one more than your
4245 # PID. Either "${$+}" or "$${+}" are workable
4246 # disambiguations, but if the programmer did the former,
4247 # they'd be in the "else" clause below rather than here.
4248 # It's not clear if this should somehow be unified with
4249 # the code in dq and re_dq that also adds lexer
4250 # disambiguation braces.
4251 $str = '$' . "{$1}"; #'
4253 return $type . $str;
4255 return $type . "{" . $self->deparse($kid, 0) . "}";
4259 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
4260 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
4263 my ($self, $op, $cx) = @_;
4264 my $str = rv2x(@_, "%");
4265 if ($op->private & OPpRV2HV_ISKEYS) {
4266 $str = $self->add_keys_keyword($str, $cx);
4268 return maybe_local(@_, $str);
4275 my $kid = $op->first;
4276 if ($kid->name eq "padav") {
4277 return $self->maybe_local($op, $cx, '$#' . $self->padany($kid));
4280 if ( $kid->name eq "rv2av"
4281 && ($kkid = $kid->first)
4282 && $kkid->name !~ /^(scope|leave|gv)$/)
4284 # handle (expr)->$#* postfix form
4286 $expr = $self->deparse($kkid, 24); # 24 is '->'
4287 $expr = "$expr->\$#*";
4288 # XXX maybe_local is probably wrong here: local($#-expression)
4289 # doesn't "do" local (the is no INTRO flag set)
4290 return $self->maybe_local($op, $cx, $expr);
4293 # handle $#{expr} form
4294 # XXX see maybe_local comment above
4295 return $self->maybe_local($op, $cx, $self->rv2x($kid, $cx, '$#'));
4300 # skip down to the old, ex-rv2cv
4302 my ($self, $op, $cx) = @_;
4303 if (!null($op->first) && $op->first->name eq 'null' &&
4304 $op->first->targ == OP_LIST)
4306 return $self->rv2x($op->first->first->sibling, $cx, "&")
4309 return $self->rv2x($op, $cx, "")
4315 my($cx, @list) = @_;
4316 my @a = map $self->const($_, 6), @list;
4321 } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
4322 # collapse (-1,0,1,2) into (-1..2)
4323 my ($s, $e) = @a[0,-1];
4325 return $self->maybe_parens("$s..$e", $cx, 9)
4326 unless grep $i++ != $_, @a;
4328 return $self->maybe_parens(join(", ", @a), $cx, 6);
4334 my $kid = $op->first;
4335 if ($kid->name eq "const") { # constant list
4336 my $av = $self->const_sv($kid);
4337 return $self->list_const($cx, $av->ARRAY);
4339 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
4343 sub is_subscriptable {
4345 if ($op->name =~ /^([ahg]elem|multideref$)/) {
4347 } elsif ($op->name eq "entersub") {
4348 my $kid = $op->first;
4349 return 0 unless null $kid->sibling;
4351 $kid = $kid->sibling until null $kid->sibling;
4352 return 0 if is_scope($kid);
4354 return 0 if $kid->name eq "gv" || $kid->name eq "padcv";
4355 return 0 if is_scalar($kid);
4356 return is_subscriptable($kid);
4362 sub elem_or_slice_array_name
4365 my ($array, $left, $padname, $allow_arrow) = @_;
4367 if ($array->name eq $padname) {
4368 return $self->padany($array);
4369 } elsif (is_scope($array)) { # ${expr}[0]
4370 return "{" . $self->deparse($array, 0) . "}";
4371 } elsif ($array->name eq "gv") {
4372 ($array, my $quoted) =
4373 $self->stash_variable_name(
4374 $left eq '[' ? '@' : '%', $self->gv_or_padgv($array)
4376 if (!$allow_arrow && $quoted) {
4377 # This cannot happen.
4378 die "Invalid variable name $array for slice";
4380 return $quoted ? "$array->" : $array;
4381 } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
4382 return $self->deparse($array, 24);
4388 sub elem_or_slice_single_index
4393 $idx = $self->deparse($idx, 1);
4395 # Outer parens in an array index will confuse perl
4396 # if we're interpolating in a regular expression, i.e.
4397 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
4399 # If $self->{parens}, then an initial '(' will
4400 # definitely be paired with a final ')'. If
4401 # !$self->{parens}, the misleading parens won't
4402 # have been added in the first place.
4404 # [You might think that we could get "(...)...(...)"
4405 # where the initial and final parens do not match
4406 # each other. But we can't, because the above would
4407 # only happen if there's an infix binop between the
4408 # two pairs of parens, and *that* means that the whole
4409 # expression would be parenthesized as well.]
4411 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
4413 # Hash-element braces will autoquote a bareword inside themselves.
4414 # We need to make sure that C<$hash{warn()}> doesn't come out as
4415 # C<$hash{warn}>, which has a quite different meaning. Currently
4416 # B::Deparse will always quote strings, even if the string was a
4417 # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
4418 # for constant strings.) So we can cheat slightly here - if we see
4419 # a bareword, we know that it is supposed to be a function call.
4421 $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
4428 my ($op, $cx, $left, $right, $padname) = @_;
4429 my($array, $idx) = ($op->first, $op->first->sibling);
4431 $idx = $self->elem_or_slice_single_index($idx);
4433 unless ($array->name eq $padname) { # Maybe this has been fixed
4434 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
4436 if (my $array_name=$self->elem_or_slice_array_name
4437 ($array, $left, $padname, 1)) {
4438 return ($array_name =~ /->\z/
4440 : $array_name eq '#' ? '${#}' : "\$" . $array_name)
4441 . $left . $idx . $right;
4443 # $x[20][3]{hi} or expr->[20]
4444 my $arrow = is_subscriptable($array) ? "" : "->";
4445 return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
4450 # a simplified version of elem_or_slice_array_name()
4451 # for the use of pp_multideref
4453 sub multideref_var_name {
4455 my ($gv, $is_hash) = @_;
4457 my ($name, $quoted) =
4458 $self->stash_variable_name( $is_hash ? '%' : '@', $gv);
4459 return $quoted ? "$name->"
4461 ? '${#}' # avoid ${#}[1] => $#[1]
4466 # deparse an OP_MULTICONCAT. If $in_dq is 1, we're within
4467 # a double-quoted string, so for example.
4469 # might get compiled as
4470 # multiconcat("abc", metaquote(multiconcat("def", $x)), "bar")
4471 # and the inner multiconcat should be deparsed as C<def$x> rather than
4472 # the normal C<def . $x>
4473 # Ditto if $in_dq is 2, handle qr/...\Qdef$x\E.../.
4475 sub do_multiconcat {
4477 my($op, $cx, $in_dq) = @_;
4485 for ($kid = $op->first; !null $kid; $kid = $kid->sibling) {
4486 # skip the consts and/or padsv we've optimised away
4488 unless $kid->type == OP_NULL
4489 && ( $kid->targ == OP_PADSV
4490 || $kid->targ == OP_CONST
4491 || $kid->targ == OP_PUSHMARK);
4494 $append = ($op->private & OPpMULTICONCAT_APPEND);
4496 if ($op->private & OPpTARGET_MY) {
4497 # '$lex = ...' or '$lex .= ....' or 'my $lex = '
4498 $lhs = $self->padname($op->targ);
4499 $lhs = "my $lhs" if ($op->private & OPpLVAL_INTRO);
4502 elsif ($op->flags & OPf_STACKED) {
4503 # 'expr = ...' or 'expr .= ....'
4504 my $expr = $append ? shift(@kids) : pop(@kids);
4505 $lhs = $self->deparse($expr, 7);
4510 $lhs .= $append ? ' .= ' : ' = ';
4513 my ($nargs, $const_str, @const_lens) = $op->aux_list($self->{curcv});
4519 push @consts, undef;
4522 push @consts, substr($const_str, $i, $_);
4531 || (($op->private & OPpMULTICONCAT_STRINGIFY) && !$self->{'unquote'}))
4533 # "foo=$foo bar=$bar "
4537 my $s = $self->dq(shift(@kids), 18);
4538 # don't deparse "a${$}b" as "a$$b"
4539 $s = '${$}' if $s eq '$$';
4540 $rhs = dq_disambiguate($rhs, $s);
4543 my $c = shift @consts;
4546 # in pattern: don't convert newline to '\n' etc etc
4547 my $s = re_uninterp(escape_re(re_unback($c)));
4548 $rhs = re_dq_disambiguate($rhs, $s)
4551 my $s = uninterp(escape_str(unback($c)));
4552 $rhs = dq_disambiguate($rhs, $s)
4556 return $rhs if $in_dq;
4557 $rhs = single_delim("qq", '"', $rhs, $self);
4559 elsif ($op->private & OPpMULTICONCAT_FAKE) {
4560 # sprintf("foo=%s bar=%s ", $foo, $bar)
4563 @consts = map { $_ //= ''; s/%/%%/g; $_ } @consts;
4564 my $fmt = join '%s', @consts;
4565 push @all, $self->quoted_const_str($fmt);
4567 # the following is a stripped down copy of sub listop {}
4568 my $parens = $assign || ($cx >= 5) || $self->{'parens'};
4569 my $fullname = $self->keyword('sprintf');
4570 push @all, map $self->deparse($_, 6), @kids;
4573 ? "$fullname(" . join(", ", @all) . ")"
4574 : "$fullname " . join(", ", @all);
4577 # "foo=" . $foo . " bar=" . $bar
4581 push @all, $self->deparse(shift(@kids), 18) if $not_first;
4583 my $c = shift @consts;
4585 push @all, $self->quoted_const_str($c);
4588 $rhs .= join ' . ', @all;
4591 my $text = $lhs . $rhs;
4593 $text = "($text)" if ($cx >= (($assign) ? 7 : 18+1))
4594 || $self->{'parens'};
4600 sub pp_multiconcat {
4602 $self->do_multiconcat(@_, 0);
4611 if ($op->private & OPpMULTIDEREF_EXISTS) {
4612 $text = $self->keyword("exists"). " ";
4614 elsif ($op->private & OPpMULTIDEREF_DELETE) {
4615 $text = $self->keyword("delete"). " ";
4617 elsif ($op->private & OPpLVAL_INTRO) {
4618 $text = $self->keyword("local"). " ";
4621 if ($op->first && ($op->first->flags & OPf_KIDS)) {
4622 # arbitrary initial expression, e.g. f(1,2,3)->[...]
4623 my $expr = $self->deparse($op->first, 24);
4624 # stop "exists (expr)->{...}" being interpreted as
4625 #"(exists (expr))->{...}"
4626 $expr = "+$expr" if $expr =~ /^\(/;
4630 my @items = $op->aux_list($self->{curcv});
4631 my $actions = shift @items;
4637 if (($actions & MDEREF_ACTION_MASK) == MDEREF_reload) {
4638 $actions = shift @items;
4643 ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_pop_rv2hv_helem
4644 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvsv_vivify_rv2hv_helem
4645 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padsv_vivify_rv2hv_helem
4646 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_vivify_rv2hv_helem
4647 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem
4648 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem
4651 if ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_padav_aelem
4652 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem)
4655 $text .= '$' . substr($self->padname(shift @items), 1);
4657 elsif ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_gvav_aelem
4658 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem)
4661 $text .= $self->multideref_var_name(shift @items, $is_hash);
4664 if ( ($actions & MDEREF_ACTION_MASK) ==
4665 MDEREF_AV_padsv_vivify_rv2av_aelem
4666 || ($actions & MDEREF_ACTION_MASK) ==
4667 MDEREF_HV_padsv_vivify_rv2hv_helem)
4669 $text .= $self->padname(shift @items);
4671 elsif ( ($actions & MDEREF_ACTION_MASK) ==
4672 MDEREF_AV_gvsv_vivify_rv2av_aelem
4673 || ($actions & MDEREF_ACTION_MASK) ==
4674 MDEREF_HV_gvsv_vivify_rv2hv_helem)
4676 $text .= $self->multideref_var_name(shift @items, $is_hash);
4678 elsif ( ($actions & MDEREF_ACTION_MASK) ==
4679 MDEREF_AV_pop_rv2av_aelem
4680 || ($actions & MDEREF_ACTION_MASK) ==
4681 MDEREF_HV_pop_rv2hv_helem)
4683 if ( ($op->flags & OPf_KIDS)
4684 && ( _op_is_or_was($op->first, OP_RV2AV)
4685 || _op_is_or_was($op->first, OP_RV2HV))
4686 && ($op->first->flags & OPf_KIDS)
4687 && ( _op_is_or_was($op->first->first, OP_AELEM)
4688 || _op_is_or_was($op->first->first, OP_HELEM))
4695 $text .= '->' if !$derefs++;
4699 if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_none) {
4703 $text .= $is_hash ? '{' : '[';
4705 if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_const) {
4706 my $key = shift @items;
4708 $text .= $self->const($key, $cx);
4714 elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_padsv) {
4715 $text .= $self->padname(shift @items);
4717 elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_gvsv) {
4718 $text .= '$' . ($self->stash_variable_name('$', shift @items))[0];
4721 $text .= $is_hash ? '}' : ']';
4723 if ($actions & MDEREF_FLAG_last) {
4726 $actions >>= MDEREF_SHIFT;
4733 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
4734 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
4739 my($glob, $part) = ($op->first, $op->last);
4740 $glob = $glob->first; # skip rv2gv
4741 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
4742 my $scope = is_scope($glob);
4743 $glob = $self->deparse($glob, 0);
4744 $part = $self->deparse($part, 1);
4745 $glob =~ s/::\z// unless $scope;
4746 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
4751 my ($op, $cx, $left, $right, $regname, $padname) = @_;
4753 my(@elems, $kid, $array, $list);
4754 if (class($op) eq "LISTOP") {
4756 } else { # ex-hslice inside delete()
4757 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
4761 $array = $array->first
4762 if $array->name eq $regname or $array->name eq "null";
4763 $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
4764 $kid = $op->first->sibling; # skip pushmark
4765 if ($kid->name eq "list") {
4766 $kid = $kid->first->sibling; # skip list, pushmark
4767 for (; !null $kid; $kid = $kid->sibling) {
4768 push @elems, $self->deparse($kid, 6);
4770 $list = join(", ", @elems);
4772 $list = $self->elem_or_slice_single_index($kid);
4774 my $lead = ( _op_is_or_was($op, OP_KVHSLICE)
4775 || _op_is_or_was($op, OP_KVASLICE))
4777 return $lead . $array . $left . $list . $right;
4780 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
4781 sub pp_kvaslice { slice(@_, "[", "]", "rv2av", "padav") }
4782 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
4783 sub pp_kvhslice { slice(@_, "{", "}", "rv2hv", "padhv") }
4788 my $idx = $op->first;
4789 my $list = $op->last;
4791 $list = $self->deparse($list, 1);
4792 $idx = $self->deparse($idx, 1);
4793 return "($list)" . "[$idx]";
4798 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
4803 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
4809 my $kid = $op->first->sibling; # skip pushmark
4810 my($meth, $obj, @exprs);
4811 if ($kid->name eq "list" and want_list $kid) {
4812 # When an indirect object isn't a bareword but the args are in
4813 # parens, the parens aren't part of the method syntax (the LLAFR
4814 # doesn't apply), but they make a list with OPf_PARENS set that
4815 # doesn't get flattened by the append_elem that adds the method,
4816 # making a (object, arg1, arg2, ...) list where the object
4817 # usually is. This can be distinguished from
4818 # '($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
4819 # object) because in the later the list is in scalar context
4820 # as the left side of -> always is, while in the former
4821 # the list is in list context as method arguments always are.
4822 # (Good thing there aren't method prototypes!)
4823 $meth = $kid->sibling;
4824 $kid = $kid->first->sibling; # skip pushmark
4826 $kid = $kid->sibling;
4827 for (; not null $kid; $kid = $kid->sibling) {
4832 $kid = $kid->sibling;
4833 for (; !null ($kid->sibling) && $kid->name!~/^method(?:_named)?\z/;
4834 $kid = $kid->sibling) {
4840 if ($meth->name eq "method_named") {
4841 $meth = $self->meth_sv($meth)->PV;
4842 } elsif ($meth->name eq "method_super") {
4843 $meth = "SUPER::".$self->meth_sv($meth)->PV;
4844 } elsif ($meth->name eq "method_redir") {
4845 $meth = $self->meth_rclass_sv($meth)->PV.'::'.$self->meth_sv($meth)->PV;
4846 } elsif ($meth->name eq "method_redir_super") {
4847 $meth = $self->meth_rclass_sv($meth)->PV.'::SUPER::'.
4848 $self->meth_sv($meth)->PV;
4850 $meth = $meth->first;
4851 if ($meth->name eq "const") {
4852 # As of 5.005_58, this case is probably obsoleted by the
4853 # method_named case above
4854 $meth = $self->const_sv($meth)->PV; # needs to be bare
4858 return { method => $meth, variable_method => ref($meth),
4859 object => $obj, args => \@exprs },
4863 # compat function only
4866 my $info = $self->_method(@_);
4867 return $self->e_method( $self->_method(@_) );
4871 my ($self, $info, $cx) = @_;
4872 my $obj = $self->deparse($info->{object}, 24);
4874 my $meth = $info->{method};
4875 $meth = $self->deparse($meth, 1) if $info->{variable_method};
4876 my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
4877 if ($info->{object}->name eq 'scope' && want_list $info->{object}) {
4878 # method { $object }
4879 # This must be deparsed this way to preserve list context
4881 my $need_paren = $cx >= 6;
4882 return '(' x $need_paren
4883 . $meth . substr($obj,2) # chop off the "do"
4885 . ')' x $need_paren;
4887 my $kid = $obj . "->" . $meth;
4889 return $kid . "(" . $args . ")"; # parens mandatory
4895 # returns "&" if the prototype doesn't match the args,
4896 # or ("", $args_after_prototype_demunging) if it does.
4899 return "&" if $self->{'noproto'};
4900 my($proto, @args) = @_;
4904 # An unbackslashed @ or % gobbles up the rest of the args
4905 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
4908 $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;|)\s*//;
4911 return "&" if @args;
4912 } elsif ($chr eq ";") {
4914 } elsif ($chr eq "@" or $chr eq "%") {
4915 push @reals, map($self->deparse($_, 6), @args);
4920 if ($chr eq "\$" || $chr eq "_") {
4921 if (want_scalar $arg) {
4922 push @reals, $self->deparse($arg, 6);
4926 } elsif ($chr eq "&") {
4927 if ($arg->name =~ /^(s?refgen|undef)$/) {
4928 push @reals, $self->deparse($arg, 6);
4932 } elsif ($chr eq "*") {
4933 if ($arg->name =~ /^s?refgen$/
4934 and $arg->first->first->name eq "rv2gv")
4936 $real = $arg->first->first; # skip refgen, null
4937 if ($real->first->name eq "gv") {
4938 push @reals, $self->deparse($real, 6);
4940 push @reals, $self->deparse($real->first, 6);
4945 } elsif (substr($chr, 0, 1) eq "\\") {
4947 if ($arg->name =~ /^s?refgen$/ and
4948 !null($real = $arg->first) and
4949 ($chr =~ /\$/ && is_scalar($real->first)
4951 && class($real->first->sibling) ne 'NULL'
4952 && $real->first->sibling->name
4955 && class($real->first->sibling) ne 'NULL'
4956 && $real->first->sibling->name
4958 #or ($chr =~ /&/ # This doesn't work
4959 # && $real->first->name eq "rv2cv")
4961 && $real->first->name eq "rv2gv")))
4963 push @reals, $self->deparse($real, 6);
4970 return "&" if $proto and !$doneok; # too few args and no ';'
4971 return "&" if @args; # too many args
4972 return ("", join ", ", @reals);
4976 my $name = $_[0]->name;
4977 # XXX There has to be a better way of doing this scalar-op check.
4978 # Currently PL_opargs is not exposed.
4979 if ($name eq 'null') {
4980 $name = substr B::ppname($_[0]->targ), 3
4982 $name =~ /^(?:scalar|pushmark|wantarray|const|gvsv|gv|padsv|rv2gv
4983 |rv2sv|av2arylen|anoncode|prototype|srefgen|ref|bless
4984 |regcmaybe|regcreset|regcomp|qr|subst|substcont|trans
4985 |transr|sassign|chop|schop|chomp|schomp|defined|undef
4986 |study|pos|preinc|i_preinc|predec|i_predec|postinc
4987 |i_postinc|postdec|i_postdec|pow|multiply|i_multiply
4988 |divide|i_divide|modulo|i_modulo|add|i_add|subtract
4989 |i_subtract|concat|multiconcat|stringify|left_shift|right_shift|lt
4990 |i_lt|gt|i_gt|le|i_le|ge|i_ge|eq|i_eq|ne|i_ne|ncmp|i_ncmp
4991 |slt|sgt|sle|sge|seq|sne|scmp|[sn]?bit_(?:and|x?or)|negate
4992 |i_negate|not|[sn]?complement|smartmatch|atan2|sin|cos
4993 |rand|srand|exp|log|sqrt|int|hex|oct|abs|length|substr
4994 |vec|index|rindex|sprintf|formline|ord|chr|crypt|ucfirst
4995 |lcfirst|uc|lc|quotemeta|aelemfast|aelem|exists|helem
4996 |pack|join|anonlist|anonhash|push|pop|shift|unshift|xor
4997 |andassign|orassign|dorassign|warn|die|reset|nextstate
4998 |dbstate|unstack|last|next|redo|dump|goto|exit|open|close
4999 |pipe_op|fileno|umask|binmode|tie|untie|tied|dbmopen
5000 |dbmclose|select|getc|read|enterwrite|prtf|print|say
5001 |sysopen|sysseek|sysread|syswrite|eof|tell|seek|truncate
5002 |fcntl|ioctl|flock|send|recv|socket|sockpair|bind|connect
5003 |listen|accept|shutdown|gsockopt|ssockopt|getsockname
5004 |getpeername|ftrread|ftrwrite|ftrexec|fteread|ftewrite
5005 |fteexec|ftis|ftsize|ftmtime|ftatime|ftctime|ftrowned
5006 |fteowned|ftzero|ftsock|ftchr|ftblk|ftfile|ftdir|ftpipe
5007 |ftsuid|ftsgid|ftsvtx|ftlink|fttty|fttext|ftbinary|chdir
5008 |chown|chroot|unlink|chmod|utime|rename|link|symlink
5009 |readlink|mkdir|rmdir|open_dir|telldir|seekdir|rewinddir
5010 |closedir|fork|wait|waitpid|system|exec|kill|getppid
5011 |getpgrp|setpgrp|getpriority|setpriority|time|alarm|sleep
5012 |shmget|shmctl|shmread|shmwrite|msgget|msgctl|msgsnd
5013 |msgrcv|semop|semget|semctl|hintseval|shostent|snetent
5014 |sprotoent|sservent|ehostent|enetent|eprotoent|eservent
5015 |spwent|epwent|sgrent|egrent|getlogin|syscall|lock|runcv
5022 return $self->e_method($self->_method($op, $cx))
5023 unless null $op->first->sibling;
5027 if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
5029 } elsif ($op->private & OPpENTERSUB_AMPER) {
5033 $kid = $kid->first->sibling; # skip ex-list, pushmark
5034 for (; not null $kid->sibling; $kid = $kid->sibling) {
5040 if (is_scope($kid)) {
5042 $kid = "{" . $self->deparse($kid, 0) . "}";
5043 } elsif ($kid->first->name eq "gv") {
5044 my $gv = $self->gv_or_padgv($kid->first);
5046 if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL"
5047 || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') {
5048 $proto = $cv->PV if $cv->FLAGS & SVf_POK;
5050 $simple = 1; # only calls of named functions can be prototyped
5051 $kid = $self->maybe_qualify("!", $self->gv_name($gv));
5053 # Fully qualify any sub name that conflicts with a lexical.
5054 if ($self->lex_in_scope("&$kid")
5055 || $self->lex_in_scope("&$kid", 1))
5059 if ($kid eq 'main::') {
5063 if ($kid !~ /::/ && $kid ne 'x') {
5064 # Fully qualify any sub name that is also a keyword. While
5065 # we could check the import flag, we cannot guarantee that
5066 # the code deparsed so far would set that flag, so we qual-
5067 # ify the names regardless of importation.
5068 if (exists $feature_keywords{$kid}) {
5069 $fq++ if $self->feature_enabled($kid);
5070 } elsif (do { local $@; local $SIG{__DIE__};
5071 eval { () = prototype "CORE::$kid"; 1 } }) {
5075 if ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
5076 $kid = single_delim("q", "'", $kid, $self) . '->';
5080 $fq and substr $kid, 0, 0, = $self->{'curstash'}.'::';
5081 } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
5083 $kid = $self->deparse($kid, 24);
5086 my $grandkid = $kid->first;
5087 my $arrow = ($lexical = $grandkid->name eq "padcv")
5088 || is_subscriptable($grandkid)
5091 $kid = $self->deparse($kid, 24) . $arrow;
5093 my $padlist = $self->{'curcv'}->PADLIST;
5094 my $padoff = $grandkid->targ;
5095 my $padname = $padlist->ARRAYelt(0)->ARRAYelt($padoff);
5096 my $protocv = $padname->FLAGS & SVpad_STATE
5097 ? $padlist->ARRAYelt(1)->ARRAYelt($padoff)
5098 : $padname->PROTOCV;
5099 if ($protocv->FLAGS & SVf_POK) {
5100 $proto = $protocv->PV
5106 # Doesn't matter how many prototypes there are, if
5107 # they haven't happened yet!
5108 my $declared = $lexical || exists $self->{'subs_declared'}{$kid};
5109 if (not $declared and $self->{'in_coderef2text'}) {
5111 no warnings 'uninitialized';
5114 defined &{ ${$self->{'curstash'}."::"}{$kid} }
5116 $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
5117 && defined prototype $self->{'curstash'}."::".$kid
5120 if (!$declared && defined($proto)) {
5121 # Avoid "too early to check prototype" warning
5122 ($amper, $proto) = ('&');
5127 if ($declared and defined $proto and not $amper) {
5128 ($amper, $args) = $self->check_proto($proto, @exprs);
5132 $args = join(", ", map(
5133 ($_->flags & OPf_WANT) == OPf_WANT_SCALAR
5135 ? $self->maybe_parens_unop('scalar', $_, 6)
5136 : $self->deparse($_, 6),
5140 if ($prefix or $amper) {
5141 if ($kid eq '&') { $kid = "{$kid}" } # &{&} cannot be written as &&
5142 if ($op->flags & OPf_STACKED) {
5143 return $prefix . $amper . $kid . "(" . $args . ")";
5145 return $prefix . $amper. $kid;
5148 # It's a syntax error to call CORE::GLOBAL::foo with a prefix,
5149 # so it must have been translated from a keyword call. Translate
5151 $kid =~ s/^CORE::GLOBAL:://;
5153 my $dproto = defined($proto) ? $proto : "undefined";
5154 my $scalar_proto = $dproto =~ /^;*(?:[\$*_+]|\\.|\\\[[^]]\])\z/;
5156 return "$kid(" . $args . ")";
5157 } elsif ($dproto =~ /^\s*\z/) {
5159 } elsif ($scalar_proto and is_scalar($exprs[0])) {
5160 # is_scalar is an excessively conservative test here:
5161 # really, we should be comparing to the precedence of the
5162 # top operator of $exprs[0] (ala unop()), but that would
5163 # take some major code restructuring to do right.
5164 return $self->maybe_parens_func($kid, $args, $cx, 16);
5165 } elsif (not $scalar_proto and defined($proto) || $simple) { #'
5166 return $self->maybe_parens_func($kid, $args, $cx, 5);
5168 return "$kid(" . $args . ")";
5173 sub pp_enterwrite { unop(@_, "write") }
5175 # escape things that cause interpolation in double quotes,
5176 # but not character escapes
5179 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
5187 # Matches any string which is balanced with respect to {braces}
5198 # the same, but treat $|, $), $( and $ at the end of the string differently
5199 # and leave comments unmangled for the sake of /x and (?x).
5213 ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
5214 | \#[^\n]* # (skip over comments)
5221 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
5227 # character escapes, but not delimiters that might need to be escaped
5228 sub escape_str { # ASCII, UTF8
5230 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
5232 # $str =~ s/\cH/\\b/g; # \b means something different in a regex; and \cH
5233 # isn't a backspace in EBCDIC
5239 $str =~ s/([\cA-\cZ])/'\\c' . $unctrl{$1}/ge;
5240 $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/age;
5244 # For regexes. Leave whitespace unmangled in case of /x or (?x).
5247 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
5248 $str =~ s/([[:^print:]])/
5249 ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/age;
5250 $str =~ s/\n/\n\f/g;
5254 # Don't do this for regexen
5257 $str =~ s/\\/\\\\/g;
5261 # Remove backslashes which precede literal control characters,
5262 # to avoid creating ambiguity when we escape the latter.
5264 # Don't remove a backslash from escaped whitespace: where the T represents
5265 # a literal tab character, /T/x is not equivalent to /\T/x
5270 # the insane complexity here is due to the behaviour of "\c\"
5272 # these two lines ensure that the backslash we're about to
5273 # remove isn't preceeded by something which makes it part
5276 (^ | [^\\] | \\c\\) # $1
5279 # the backslash to remove
5282 # keep pairs of backslashes
5285 # only remove if the thing following is a control char
5287 # and not whitespace
5293 sub balanced_delim {
5295 my @str = split //, $str;
5296 my($ar, $open, $close, $fail, $c, $cnt, $last_bs);
5297 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
5298 ($open, $close) = @$ar;
5299 $fail = 0; $cnt = 0; $last_bs = 0;
5302 $fail = 1 if $last_bs;
5304 } elsif ($c eq $close) {
5305 $fail = 1 if $last_bs;
5313 $last_bs = $c eq '\\';
5315 $fail = 1 if $cnt != 0;
5316 return ($open, "$open$str$close") if not $fail;
5322 my($q, $default, $str, $self) = @_;
5323 return "$default$str$default" if $default and index($str, $default) == -1;
5324 my $coreq = $self->keyword($q); # maybe CORE::q
5326 (my $succeed, $str) = balanced_delim($str);
5327 return "$coreq$str" if $succeed;
5329 for my $delim ('/', '"', '#') {
5330 return "$coreq$delim" . $str . $delim if index($str, $delim) == -1;
5333 $str =~ s/$default/\\$default/g;
5334 return "$default$str$default";
5337 return "$coreq/$str/";
5342 BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
5344 # Split a floating point number into an integer mantissa and a binary
5345 # exponent. Assumes you've already made sure the number isn't zero or
5346 # some weird infinity or NaN.
5350 if ($f == int($f)) {
5351 while ($f % 2 == 0) {
5356 while ($f != int($f)) {
5361 my $mantissa = sprintf("%.0f", $f);
5362 return ($mantissa, $exponent);
5366 # suitably single- or double-quote a literal constant string
5368 sub quoted_const_str {
5369 my ($self, $str) =@_;
5370 if ($str =~ /[[:^print:]]/a) {
5371 return single_delim("qq", '"',
5372 uninterp(escape_str unback $str), $self);
5374 return single_delim("q", "'", unback($str), $self);
5382 if ($self->{'use_dumper'}) {
5383 return $self->const_dumper($sv, $cx);
5385 if (class($sv) eq "SPECIAL") {
5386 # sv_undef, sv_yes, sv_no
5387 return $$sv == 3 ? $self->maybe_parens("!1", $cx, 21)
5388 : ('undef', '1')[$$sv-1];
5390 if (class($sv) eq "NULL") {
5393 # convert a version object into the "v1.2.3" string in its V magic
5394 if ($sv->FLAGS & SVs_RMG) {
5395 for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
5396 return $mg->PTR if $mg->TYPE eq 'V';
5400 if ($sv->FLAGS & SVf_IOK) {
5401 my $str = $sv->int_value;
5402 $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
5404 } elsif ($sv->FLAGS & SVf_NOK) {
5407 if (pack("F", $nv) eq pack("F", 0)) {
5412 return $self->maybe_parens("-.0", $cx, 21);
5414 } elsif (1/$nv == 0) {
5417 return $self->maybe_parens("9**9**9", $cx, 22);
5420 return $self->maybe_parens("-9**9**9", $cx, 21);
5422 } elsif ($nv != $nv) {
5424 if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
5426 return "sin(9**9**9)";
5427 } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
5429 return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
5432 my $hex = unpack("h*", pack("F", $nv));
5433 return qq'unpack("F", pack("h*", "$hex"))';
5436 # first, try the default stringification
5439 # failing that, try using more precision
5440 $str = sprintf("%.${max_prec}g", $nv);
5441 # if (pack("F", $str) ne pack("F", $nv)) {
5443 # not representable in decimal with whatever sprintf()
5444 # and atof() Perl is using here.
5445 my($mant, $exp) = split_float($nv);
5446 return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
5449 $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
5451 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
5453 my $class = class($ref);
5454 if ($class eq "AV") {
5455 return "[" . $self->list_const(2, $ref->ARRAY) . "]";
5456 } elsif ($class eq "HV") {
5457 my %hash = $ref->ARRAY;
5459 for my $k (sort keys %hash) {
5460 push @elts, "$k => " . $self->const($hash{$k}, 6);
5462 return "{" . join(", ", @elts) . "}";
5463 } elsif ($class eq "CV") {
5465 if ($self->{curcv} &&
5466 $self->{curcv}->object_2svref == $ref->object_2svref) {
5467 return $self->keyword("__SUB__");
5469 return "sub " . $self->deparse_sub($ref);
5471 if ($class ne 'SPECIAL' and $ref->FLAGS & SVs_SMG) {
5472 for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
5473 if ($mg->TYPE eq 'r') {
5474 my $re = re_uninterp(escape_re(re_unback($mg->precomp)));
5475 return single_delim("qr", "", $re, $self);
5480 my $const = $self->const($ref, 20);
5481 if ($self->{in_subst_repl} && $const =~ /^[0-9]/) {
5482 $const = "($const)";
5484 return $self->maybe_parens("\\$const", $cx, 20);
5485 } elsif ($sv->FLAGS & SVf_POK) {
5487 return $self->quoted_const_str($str);
5496 my $ref = $sv->object_2svref();
5497 my $dumper = Data::Dumper->new([$$ref], ['$v']);
5498 $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
5499 my $str = $dumper->Dump();
5500 if ($str =~ /^\$v/) {
5501 return '${my ' . $str . ' \$v}';
5511 # the constant could be in the pad (under useithreads)
5512 $sv = $self->padval($op->targ) unless $$sv;
5519 my $sv = $op->meth_sv;
5520 # the constant could be in the pad (under useithreads)
5521 $sv = $self->padval($op->targ) unless $$sv;
5525 sub meth_rclass_sv {
5528 my $sv = $op->rclass;
5529 # the constant could be in the pad (under useithreads)
5530 $sv = $self->padval($sv) unless ref $sv;
5537 # if ($op->private & OPpCONST_BARE) { # trouble with '=>' autoquoting
5538 # return $self->const_sv($op)->PV;
5540 my $sv = $self->const_sv($op);
5541 return $self->const($sv, $cx);
5545 # Join two components of a double-quoted string, disambiguating
5546 # "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
5548 sub dq_disambiguate {
5549 my ($first, $last) = @_;
5550 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
5551 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
5552 || ($last =~ /^[:'{\[\w_]/ && #'
5553 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
5554 return $first . $last;
5558 # Deparse a double-quoted optree. For example, "$a[0]\Q$b\Efo\"o" gets
5559 # compiled to concat(concat($[0],quotemeta($b)),const("fo\"o")), and this
5560 # sub deparses it back to $a[0]\Q$b\Efo"o
5561 # (It does not add delimiters)
5566 my $type = $op->name;
5567 if ($type eq "const") {
5568 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
5569 } elsif ($type eq "concat") {
5570 return dq_disambiguate($self->dq($op->first), $self->dq($op->last));
5571 } elsif ($type eq "multiconcat") {
5572 return $self->do_multiconcat($op, 26, 1);
5573 } elsif ($type eq "uc") {
5574 return '\U' . $self->dq($op->first->sibling) . '\E';
5575 } elsif ($type eq "lc") {
5576 return '\L' . $self->dq($op->first->sibling) . '\E';
5577 } elsif ($type eq "ucfirst") {
5578 return '\u' . $self->dq($op->first->sibling);
5579 } elsif ($type eq "lcfirst") {
5580 return '\l' . $self->dq($op->first->sibling);
5581 } elsif ($type eq "quotemeta") {
5582 return '\Q' . $self->dq($op->first->sibling) . '\E';
5583 } elsif ($type eq "fc") {
5584 return '\F' . $self->dq($op->first->sibling) . '\E';
5585 } elsif ($type eq "join") {
5586 return $self->deparse($op->last, 26); # was join($", @ary)
5588 return $self->deparse($op, 26);
5595 # skip pushmark if it exists (readpipe() vs ``)
5596 my $child = $op->first->sibling->isa('B::NULL')
5597 ? $op->first : $op->first->sibling;
5598 if ($self->pure_string($child)) {
5599 return single_delim("qx", '`', $self->dq($child, 1), $self);
5601 unop($self, @_, "readpipe");
5607 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
5608 return $self->deparse($kid, $cx) if $self->{'unquote'};
5609 $self->maybe_targmy($kid, $cx,
5610 sub {single_delim("qq", '"', $self->dq($_[1]),
5614 # OP_STRINGIFY is a listop, but it only ever has one arg
5616 my ($self, $op, $cx) = @_;
5617 my $kid = $op->first->sibling;
5618 while ($kid->name eq 'null' && !null($kid->first)) {
5621 if ($kid->name =~ /^(?:const|padsv|rv2sv|av2arylen|gvsv|multideref
5622 |aelemfast(?:_lex)?|[ah]elem|join|concat)\z/x) {
5623 maybe_targmy(@_, \&dquote);
5626 # Actually an optimised join.
5627 my $result = listop(@_,"join");
5628 $result =~ s/join([( ])/join$1$self->{'ex_const'}, /;
5633 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
5634 # note that tr(from)/to/ is OK, but not tr/from/(to)
5636 my($from, $to) = @_;
5637 my($succeed, $delim);
5638 if ($from !~ m[/] and $to !~ m[/]) {
5639 return "/$from/$to/";
5640 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
5641 if (($succeed, $to) = balanced_delim($to) and $succeed) {
5644 for $delim ('/', '"', '#') { # note no "'" -- s''' is special
5645 return "$from$delim$to$delim" if index($to, $delim) == -1;
5648 return "$from/$to/";
5651 for $delim ('/', '"', '#') { # note no '
5652 return "$delim$from$delim$to$delim"
5653 if index($to . $from, $delim) == -1;
5655 $from =~ s[/][\\/]g;
5657 return "/$from/$to/";
5661 # Escape a characrter.
5662 # Only used by tr///, so backslashes hyphens
5666 return sprintf("\\x{%X}", $n) if $n > 255;
5667 return '\\\\' if $n == ord '\\';
5668 return "\\-" if $n == ord "-";
5669 # I'm presuming a regex is not ok here, otherwise we could have used
5670 # /[[:print:]]/a to get here
5671 return chr($n) if ( utf8::native_to_unicode($n)
5672 >= utf8::native_to_unicode(ord(' '))
5673 and utf8::native_to_unicode($n)
5674 <= utf8::native_to_unicode(ord('~')));
5676 my $mnemonic_pos = index("\a\b\e\f\n\r\t", chr($n));
5677 return "\\" . substr("abefnrt", $mnemonic_pos, 1) if $mnemonic_pos >= 0;
5679 return '\\c' . $unctrl{chr $n} if $n >= ord("\cA") and $n <= ord("\cZ");
5680 # return '\x' . sprintf("%02x", $n);
5681 return '\\' . sprintf("%03o", $n);
5684 # Convert a list of characters into a string suitable for tr/// search or
5685 # replacement, with suitable escaping and collapsing of ranges
5689 my($str, $c, $tr) = ("");
5690 for ($c = 0; $c < @chars; $c++) {
5693 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
5694 $chars[$c + 2] == $tr + 2)
5696 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
5699 $str .= pchr($chars[$c]);
5705 sub tr_decode_byte {
5706 my($table, $flags) = @_;
5707 my $ssize_t = $Config{ptrsize} == 8 ? 'q' : 'l';
5708 my ($size, @table) = unpack("${ssize_t}s*", $table);
5709 pop @table; # remove the wildcard final entry
5711 my($c, $tr, @from, @to, @delfrom, $delhyphen);
5712 if ($table[ord "-"] != -1 and
5713 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
5715 $tr = $table[ord "-"];
5716 $table[ord "-"] = -1;
5720 } else { # -2 ==> delete
5724 for ($c = 0; $c < @table; $c++) {
5727 push @from, $c; push @to, $tr;
5728 } elsif ($tr == -2) {
5732 @from = (@from, @delfrom);
5734 if ($flags & OPpTRANS_COMPLEMENT) {
5735 unless ($flags & OPpTRANS_DELETE) {
5736 @to = () if ("@from" eq "@to");
5741 @from{@from} = (1) x @from;
5742 for ($c = 0; $c < 256; $c++) {
5743 push @newfrom, $c unless $from{$c};
5747 unless ($flags & OPpTRANS_DELETE || !@to) {
5748 pop @to while $#to and $to[$#to] == $to[$#to -1];
5751 $from = collapse(@from);
5752 $to = collapse(@to);
5753 $from .= "-" if $delhyphen;
5754 return ($from, $to);
5757 my $infinity = ~0 >> 1; # IV_MAX
5759 sub tr_append_to_invlist {
5760 my ($list_ref, $current, $next) = @_;
5762 # Appends the range $current..$next-1 to the inversion list $list_ref
5764 printf STDERR "%d: %d..%d %s", __LINE__, $current, $next, Dumper $list_ref if DEBUG;
5766 if (@$list_ref && $list_ref->[-1] == $current) {
5768 # The new range extends the current final one. If it is a finite
5769 # rane, replace the current final by the new ending.
5770 if (defined $next) {
5771 $list_ref->[-1] = $next;
5774 # The new range extends to infinity, which means the current end
5775 # of the inversion list is dangling. Removing it causes things to
5780 else { # The new range starts after the current final one; add it as a
5782 push @$list_ref, $current;
5783 push @$list_ref, $next if defined $next;
5786 print STDERR __LINE__, ": ", Dumper $list_ref if DEBUG;
5789 sub tr_invlist_to_string {
5790 my ($list_ref, $to_complement) = @_;
5792 # Stringify the inversion list $list_ref, possibly complementing it first.
5793 # CAUTION: this can modify $list_ref.
5795 print STDERR __LINE__, ": ", Dumper $list_ref if DEBUG;
5797 if ($to_complement) {
5799 # Complementing an inversion list is done by prepending a 0 if it
5800 # doesn't have one there already; otherwise removing the leading 0.
5801 if ($list_ref->[0] == 0) {
5805 unshift @$list_ref, 0;
5808 print STDERR __LINE__, ": ", Dumper $list_ref if DEBUG;
5813 # Every other element is in the list.
5814 for (my $i = 0; $i < @$list_ref; $i += 2) {
5815 my $base = $list_ref->[$i];
5816 $output .= pchr($base);
5817 last unless defined $list_ref->[$i+1];
5819 # The beginning of the next element starts the range of items not in
5821 my $upper = $list_ref->[$i+1] - 1;
5822 my $range = $upper - $base;
5823 $output .= '-' if $range > 1; # Adjacent characters don't have a
5824 # minus, though it would be legal to do
5826 $output .= pchr($upper) if $range > 0;
5829 print STDERR __LINE__, ": tr_invlist_to_string() returning '$output'\n"
5835 my $special_handling = ~0 - 1;
5838 my ($invlist_ref, $map_ref) = @_;
5840 for my $i (0 .. @$invlist_ref - 1) {
5841 printf STDERR "[%d]\t%x\t", $i, $invlist_ref->[$i];
5842 my $map = $map_ref->[$i];
5843 if ($map == $unmapped) {
5844 print STDERR "TR_UNMAPPED\n";
5846 elsif ($map == $special_handling) {
5847 print STDERR "TR_SPECIAL\n";
5850 printf STDERR "%x\n", $map;
5855 sub tr_decode_utf8 {
5856 my($tr_av, $flags) = @_;
5858 printf STDERR "\n%s: %d: flags=0x%x\n", __FILE__, __LINE__, $flags if DEBUG;
5860 my $invlist = $tr_av->ARRAYelt(0);
5861 my @invlist = unpack("J*", $invlist->PV);
5862 my @map = unpack("J*", $tr_av->ARRAYelt(1)->PV);
5864 dump_invmap(\@invlist, \@map) if DEBUG;
5869 # Go through the whole map
5870 for (my $i = 0; $i < @invlist; $i++) {
5872 printf STDERR "%d: i=%d, source=%x, map=%x\n",
5873 __LINE__, $i, $invlist[$i], $map if DEBUG;
5875 # Ignore any lines that are unmapped
5876 next if $map == $unmapped;
5878 # Calculate this component of the mapping; First the lhs
5879 my $this_from = $invlist[$i];
5880 my $next_from = $invlist[$i+1] if $i < @invlist - 1;
5882 # The length of the rhs is the same as the lhs, except when special
5883 my $next_map = $map - $this_from + $next_from
5884 if $map != $special_handling && defined $next_from;
5887 printf STDERR "%d: i=%d, from=%x, to=%x",
5888 __LINE__, $i, $this_from, $map;
5889 printf STDERR ", next_from=%x,", $next_from if defined $next_from;
5890 printf STDERR ", next_map=%x", $next_map if defined $next_map;
5895 tr_append_to_invlist(\@from, $this_from, $next_from);
5897 # And, the rhs; special handling doesn't get output as it really is an
5899 tr_append_to_invlist(\@to, $map, $next_map) if $map != $special_handling;
5902 # Done with the input.
5905 if (join("", @from) eq join("", @to)) {
5907 # the rhs is suppressed if identical to the left. That's because
5908 # tr/ABC/ABC/ can be written as tr/ABC//. (Do this comparison before
5909 # any complementing)
5913 $to = tr_invlist_to_string(\@to, 0); # rhs not complemented
5916 my $from = tr_invlist_to_string(\@from,
5917 ($flags & OPpTRANS_COMPLEMENT) != 0);
5919 print STDERR "Returning ", escape_str($from), "/",
5920 escape_str($to), "\n" if DEBUG;
5921 return (escape_str($from), escape_str($to));
5926 my($op, $cx, $morflags) = @_;
5928 my $class = class($op);
5929 my $priv_flags = $op->private;
5930 if ($class eq "PVOP") {
5931 ($from, $to) = tr_decode_byte($op->pv, $priv_flags);
5932 } elsif ($class eq "PADOP") {
5934 = tr_decode_utf8($self->padval($op->padix), $priv_flags);
5935 } else { # class($op) eq "SVOP"
5936 ($from, $to) = tr_decode_utf8($op->sv, $priv_flags);
5939 $flags .= "c" if $priv_flags & OPpTRANS_COMPLEMENT;
5940 $flags .= "d" if $priv_flags & OPpTRANS_DELETE;
5941 $to = "" if $from eq $to and $flags eq "";
5942 $flags .= "s" if $priv_flags & OPpTRANS_SQUASH;
5943 $flags .= $morflags if defined $morflags;
5944 my $ret = $self->keyword("tr") . double_delim($from, $to) . $flags;
5945 if (my $targ = $op->targ) {
5946 return $self->maybe_parens($self->padname($targ) . " =~ $ret",
5952 sub pp_transr { push @_, 'r'; goto &pp_trans }
5954 # Join two components of a double-quoted re, disambiguating
5955 # "${foo}bar", "${foo}{bar}", "${foo}[1]".
5957 sub re_dq_disambiguate {
5958 my ($first, $last) = @_;
5959 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
5960 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
5961 || ($last =~ /^[{\[\w_]/ &&
5962 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
5963 return $first . $last;
5966 # Like dq(), but different
5971 my $type = $op->name;
5972 if ($type eq "const") {
5973 my $unbacked = re_unback($self->const_sv($op)->as_string);
5974 return re_uninterp(escape_re($unbacked));
5975 } elsif ($type eq "concat") {
5976 my $first = $self->re_dq($op->first);
5977 my $last = $self->re_dq($op->last);
5978 return re_dq_disambiguate($first, $last);
5979 } elsif ($type eq "multiconcat") {
5980 return $self->do_multiconcat($op, 26, 2);
5981 } elsif ($type eq "uc") {
5982 return '\U' . $self->re_dq($op->first->sibling) . '\E';
5983 } elsif ($type eq "lc") {
5984 return '\L' . $self->re_dq($op->first->sibling) . '\E';
5985 } elsif ($type eq "ucfirst") {
5986 return '\u' . $self->re_dq($op->first->sibling);
5987 } elsif ($type eq "lcfirst") {
5988 return '\l' . $self->re_dq($op->first->sibling);
5989 } elsif ($type eq "quotemeta") {
5990 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
5991 } elsif ($type eq "fc") {
5992 return '\F' . $self->re_dq($op->first->sibling) . '\E';
5993 } elsif ($type eq "join") {
5994 return $self->deparse($op->last, 26); # was join($", @ary)
5996 my $ret = $self->deparse($op, 26);
5997 $ret =~ s/^\$([(|)])\z/\${$1}/ # $( $| $) need braces
5998 or $ret =~ s/^\@([-+])\z/\@{$1}/; # @- @+ need braces
6004 my ($self, $op) = @_;
6005 return 0 if null $op;
6006 my $type = $op->name;
6008 if ($type eq 'const' || $type eq 'av2arylen') {
6011 elsif ($type =~ /^(?:[ul]c(first)?|fc)$/ || $type eq 'quotemeta') {
6012 return $self->pure_string($op->first->sibling);
6014 elsif ($type eq 'join') {
6015 my $join_op = $op->first->sibling; # Skip pushmark
6016 return 0 unless $join_op->name eq 'null' && $join_op->targ == OP_RV2SV;
6018 my $gvop = $join_op->first;
6019 return 0 unless $gvop->name eq 'gvsv';
6020 return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
6022 return 0 unless ${$join_op->sibling} eq ${$op->last};
6023 return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
6025 elsif ($type eq 'concat') {
6026 return $self->pure_string($op->first)
6027 && $self->pure_string($op->last);
6029 elsif ($type eq 'multiconcat') {
6031 for ($kid = $op->first; !null $kid; $kid = $kid->sibling) {
6032 # skip the consts and/or padsv we've optimised away
6034 unless $kid->type == OP_NULL
6035 && ( $kid->targ == OP_PADSV
6036 || $kid->targ == OP_CONST
6037 || $kid->targ == OP_PUSHMARK);
6040 if ($op->flags & OPf_STACKED) {
6041 # remove expr from @kids where 'expr = ...' or 'expr .= ....'
6042 if ($op->private & OPpMULTICONCAT_APPEND) {
6050 return 0 unless $self->pure_string($_);
6054 elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
6057 elsif ($type eq "null" and $op->can('first') and not null $op->first) {
6058 my $first = $op->first;
6060 return 1 if $first->name eq "multideref";
6061 return 1 if $first->name eq "aelemfast_lex";
6063 if ( $first->name eq "null"
6064 and $first->can('first')
6065 and not null $first->first
6066 and $first->first->name eq "aelemfast"
6077 my ($self,$op,$cv) = @_;
6079 # localise stuff relating to the current sub
6081 local($self->{'curcv'}) = $cv,
6082 local($self->{'curcvlex'}),
6083 local(@$self{qw'curstash warnings hints hinthash curcop'})
6084 = @$self{qw'curstash warnings hints hinthash curcop'};
6087 for ($op = $op->first->sibling; !null($op); $op = $op->sibling) {
6088 if ($op->name eq 'null' and $op->flags & OPf_SPECIAL) {
6089 my $scope = $op->first;
6090 # 0 context (last arg to scopeop) means statement context, so
6091 # the contents of the block will not be wrapped in do{...}.
6092 my $block = scopeop($scope->first->name eq "enter", $self,
6094 # next op is the source code of the block
6096 $re .= ($self->const_sv($op)->PV =~ m|^(\(\?\??\{)|)[0];
6097 my $multiline = $block =~ /\n/;
6098 $re .= $multiline ? "\n\t" : ' ';
6100 $re .= $multiline ? "\n\b})" : " })";
6102 $re = re_dq_disambiguate($re, $self->re_dq($op));
6111 my $kid = $op->first;
6112 $kid = $kid->first if $kid->name eq "regcmaybe";
6113 $kid = $kid->first if $kid->name eq "regcreset";
6114 my $kname = $kid->name;
6115 if ($kname eq "null" and !null($kid->first)
6116 and $kid->first->name eq 'pushmark')
6119 $kid = $kid->first->sibling;
6120 while (!null($kid)) {
6122 my $last = $self->re_dq($kid);
6123 $str = re_dq_disambiguate($first, $last);
6124 $kid = $kid->sibling;
6129 return ($self->re_dq($kid), 1)
6130 if $kname =~ /^(?:rv2|pad)av/ or $self->pure_string($kid);
6131 return ($self->deparse($kid, $cx), 0);
6135 my ($self, $op, $cx) = @_;
6136 return (($self->regcomp($op, $cx, 0))[0]);
6140 my ($self, $op) = @_;
6142 my $pmflags = $op->pmflags;
6144 my $re = $op->pmregexp;
6146 $pmflags = $re->compflags;
6149 $flags .= "g" if $pmflags & PMf_GLOBAL;
6150 $flags .= "i" if $pmflags & PMf_FOLD;
6151 $flags .= "m" if $pmflags & PMf_MULTILINE;
6152 $flags .= "o" if $pmflags & PMf_KEEP;
6153 $flags .= "s" if $pmflags & PMf_SINGLELINE;
6154 $flags .= "x" if $pmflags & PMf_EXTENDED;
6155 $flags .= "x" if $pmflags & PMf_EXTENDED_MORE;
6156 $flags .= "p" if $pmflags & PMf_KEEPCOPY;
6157 $flags .= "n" if $pmflags & PMf_NOCAPTURE;
6158 if (my $charset = $pmflags & PMf_CHARSET) {
6159 # Hardcoding this is fragile, but B does not yet export the
6160 # constants we need.
6161 $flags .= qw(d l u a aa)[$charset >> 7]
6163 # The /d flag is indicated by 0; only show it if necessary.
6164 elsif ($self->{hinthash} and
6165 $self->{hinthash}{reflags_charset}
6166 || $self->{hinthash}{feature_unicode}
6167 or $self->{hints} & $feature::hint_mask
6168 && ($self->{hints} & $feature::hint_mask)
6169 != $feature::hint_mask
6170 && $self->{hints} & $feature::hint_uni8bit
6177 # osmic acid -- see osmium tetroxide
6180 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
6181 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
6182 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi', 'soup', 'soupmix');
6184 # When deparsing a regular expression with code blocks, we have to look in
6185 # various places to find the blocks.
6187 # For qr/(?{...})/ without interpolation, the CV is under $qr->qr_anoncv
6188 # and the code list (list of blocks and constants, maybe vars) is under
6189 # $cv->ROOT->first->code_list:
6190 # ./perl -Ilib -MB -e 'use O "Concise", B::svref_2object(sub {qr/(?{die})/})->ROOT->first->first->sibling->pmregexp->qr_anoncv->object_2svref'
6192 # For qr/$a(?{...})/ with interpolation, the code list is more accessible,
6193 # under $pmop->code_list, but the $cv is something you have to dig for in
6194 # the regcomp op’s kids:
6195 # ./perl -Ilib -mO=Concise -e 'qr/$a(?{die})/'
6197 # For m// and split //, things are much simpler. There is no CV. The code
6198 # list is under $pmop->code_list.
6202 my($op, $cx, $name, $delim) = @_;
6203 my $kid = $op->first;
6204 my ($binop, $var, $re) = ("", "", "");
6205 if ($op->name ne 'split' && $op->flags & OPf_STACKED) {
6207 $var = $self->deparse($kid, 20);
6208 $kid = $kid->sibling;
6210 # not $name; $name will be 'm' for both match and split
6211 elsif ($op->name eq 'match' and my $targ = $op->targ) {
6213 $var = $self->padname($targ);
6216 my $pmflags = $op->pmflags;
6217 my $rhs_bound_to_defsv;
6219 my $have_kid = !null $kid;
6220 # Check for code blocks first
6221 if (not null my $code_list = $op->code_list) {
6222 $re = $self->code_list($code_list,
6225 $kid->first # ex-list
6227 ->sibling # entersub
6236 } elsif (${$bregexp = $op->pmregexp} && ${$cv = $bregexp->qr_anoncv}) {
6237 my $patop = $cv->ROOT # leavesub
6240 $re = $self->code_list($patop, $cv);
6241 } elsif (!$have_kid) {
6242 $re = re_uninterp(escape_re(re_unback($op->precomp)));
6243 } elsif ($kid->name ne 'regcomp') {
6244 if ($op->name eq 'split') {
6245 # split has other kids, not just regcomp
6246 $re = re_uninterp(escape_re(re_unback($op->precomp)));
6249 carp("found ".$kid->name." where regcomp expected");
6252 ($re, $quote) = $self->regcomp($kid, 21);
6254 if ($have_kid and $kid->name eq 'regcomp') {
6255 my $matchop = $kid->first;
6256 if ($matchop->name eq 'regcreset') {
6257 $matchop = $matchop->first;
6259 if ($matchop->name =~ /^(?:match|transr?|subst)\z/
6260 && $matchop->flags & OPf_SPECIAL) {
6261 $rhs_bound_to_defsv = 1;
6265 $flags .= "c" if $pmflags & PMf_CONTINUE;
6266 $flags .= $self->re_flags($op);
6267 $flags = join '', sort split //, $flags;
6268 $flags = $matchwords{$flags} if $matchwords{$flags};
6269 if ($pmflags & PMf_ONCE) { # only one kind of delimiter works here
6271 $re = $self->keyword("m") . "?$re?"; # explicit 'm' is required
6273 $re = single_delim($name, $delim, $re, $self);
6275 $re = $re . $flags if $quote;
6278 $self->maybe_parens(
6280 ? "$var =~ (\$_ =~ $re)"
6289 sub pp_match { matchop(@_, "m", "/") }
6290 sub pp_qr { matchop(@_, "qr", "") }
6292 sub pp_runcv { unop(@_, "__SUB__"); }
6297 my($kid, @exprs, $ary, $expr);
6298 my $stacked = $op->flags & OPf_STACKED;
6301 $kid = $kid->sibling if $kid->name eq 'regcomp';
6302 for (; !null($kid); $kid = $kid->sibling) {
6303 push @exprs, $self->deparse($kid, 6);
6306 unshift @exprs, $self->matchop($op, $cx, "m", "/");
6308 if ($op->private & OPpSPLIT_ASSIGN) {
6309 # With C<@array = split(/pat/, str);>,
6310 # array is stored in split's pmreplroot; either
6311 # as an integer index into the pad (for a lexical array)
6312 # or as GV for a package array (which will be a pad index
6313 # on threaded builds)
6314 # With my/our @array = split(/pat/, str), the array is instead
6315 # accessed via an extra padav/rv2av op at the end of the
6322 if ($op->private & OPpSPLIT_LEX) {
6323 $ary = $self->padname($op->pmreplroot);
6326 # union with op_pmtargetoff, op_pmtargetgv
6327 my $gv = $op->pmreplroot;
6328 $gv = $self->padval($gv) if !ref($gv);
6329 $ary = $self->maybe_local(@_,
6330 $self->stash_variable('@',
6331 $self->gv_name($gv),
6334 if ($op->private & OPpLVAL_INTRO) {
6335 $ary = $op->private & OPpSPLIT_LEX ? "my $ary" : "local $ary";
6340 # handle special case of split(), and split(' ') that compiles to /\s+/
6341 $exprs[0] = q{' '} if ($op->reflags // 0) & RXf_SKIPWHITE();
6343 $expr = "split(" . join(", ", @exprs) . ")";
6345 return $self->maybe_parens("$ary = $expr", $cx, 7);
6351 # oxime -- any of various compounds obtained chiefly by the action of
6352 # hydroxylamine on aldehydes and ketones and characterized by the
6353 # bivalent grouping C=NOH [Webster's Tenth]
6356 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
6357 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
6358 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
6359 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi', 'rogue',
6360 'sir', 'rise', 'smore', 'more', 'seer', 'rome', 'gore', 'grim', 'grime',
6361 'or', 'rose', 'rosie');
6366 my $kid = $op->first;
6367 my($binop, $var, $re, $repl) = ("", "", "", "");
6368 if ($op->flags & OPf_STACKED) {
6370 $var = $self->deparse($kid, 20);
6371 $kid = $kid->sibling;
6373 elsif (my $targ = $op->targ) {
6375 $var = $self->padname($targ);
6378 my $pmflags = $op->pmflags;
6379 if (null($op->pmreplroot)) {
6381 $kid = $kid->sibling;
6383 $repl = $op->pmreplroot->first; # skip substcont
6385 while ($repl->name eq "entereval") {
6386 $repl = $repl->first;
6390 local $self->{in_subst_repl} = 1;
6391 if ($pmflags & PMf_EVAL) {
6392 $repl = $self->deparse($repl->first, 0);
6394 $repl = $self->dq($repl);
6397 if (not null my $code_list = $op->code_list) {
6398 $re = $self->code_list($code_list);
6399 } elsif (null $kid) {
6400 $re = re_uninterp(escape_re(re_unback($op->precomp)));
6402 ($re) = $self->regcomp($kid, 1);
6404 $flags .= "r" if $pmflags & PMf_NONDESTRUCT;
6405 $flags .= "e" if $pmflags & PMf_EVAL;
6406 $flags .= $self->re_flags($op);
6407 $flags = join '', sort split //, $flags;
6408 $flags = $substwords{$flags} if $substwords{$flags};
6409 my $core_s = $self->keyword("s"); # maybe CORE::s
6411 return $self->maybe_parens("$var =~ $core_s"
6412 . double_delim($re, $repl) . $flags,
6415 return "$core_s". double_delim($re, $repl) . $flags;
6419 sub is_lexical_subs {
6422 return 0 if $op->name !~ /\A(?:introcv|clonecv)\z/;
6427 # Pretend these two ops do not exist. The perl parser adds them to the
6428 # beginning of any block containing my-sub declarations, whereas we handle
6429 # the subs in pad_subs and next_todo.
6430 *pp_clonecv = *pp_introcv;
6434 # For now, deparsing doesn't worry about the distinction between introcv
6435 # and clonecv, so pretend this op doesn't exist:
6442 return $self->padany($op);
6445 my %lvref_funnies = (
6446 OPpLVREF_SV, => '$',
6447 OPpLVREF_AV, => '@',
6448 OPpLVREF_HV, => '%',
6449 OPpLVREF_CV, => '&',
6453 my ($self, $op, $cx) = @_;
6455 if ($op->private & OPpLVREF_ELEM) {
6456 $left = $op->first->sibling;
6457 $left = maybe_local(@_, elem($self, $left, undef,
6458 $left->targ == OP_AELEM
6461 } elsif ($op->flags & OPf_STACKED) {
6462 $left = maybe_local(@_,
6463 $lvref_funnies{$op->private & OPpLVREF_TYPE}
6464 . $self->deparse($op->first->sibling));
6468 my $right = $self->deparse_binop_right($op, $op->first, 7);
6469 return $self->maybe_parens("\\$left = $right", $cx, 7);
6473 my ($self, $op, $cx) = @_;
6475 if ($op->private & OPpLVREF_ELEM) {
6476 $code = $op->first->name =~ /av\z/ ? &pp_aelem : &pp_helem;
6477 } elsif ($op->flags & OPf_STACKED) {
6478 $code = maybe_local(@_,
6479 $lvref_funnies{$op->private & OPpLVREF_TYPE}
6480 . $self->deparse($op->first));
6488 my ($self, $op, $cx) = @_;
6489 '\\' . ($op->last->name =~ /av\z/ ? &pp_aslice : &pp_hslice);
6493 my ($self, $op, $cx) = @_;
6494 '\\(' . ($op->flags & OPf_STACKED
6495 ? maybe_local(@_, rv2x(@_, "\@"))
6503 my ($params, $opt_params, $slurpy) = $op->aux_list($self->{curcv});
6504 my $mandatory = $params - $opt_params;
6507 $check .= <<EOF if !$slurpy;
6508 die sprintf("Too many arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ <= $params;
6511 $check .= <<EOF if $mandatory > 0;
6512 die sprintf("Too few arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ >= $mandatory;
6515 my $cond = ($params & 1) ? 'unless' : 'if';
6516 $check .= <<EOF if $slurpy eq '%';
6517 die sprintf("Odd name/value argument for subroutine at %s line %d.\\n", (caller)[1, 2]) if \@_ > $params && ((\@_ - $params) & 1);
6520 $check =~ s/;\n\z//;
6528 my $var = $self->padname($op->targ);
6529 my $ix = $op->string($self->{curcv});
6531 if ($op->flags & OPf_KIDS) {
6532 $expr = $self->deparse($op->first, 7);
6534 elsif ($var =~ /^[@%]/) {
6535 $expr = $ix ? "\@_[$ix .. \$#_]" : '@_';
6540 return "my $var = $expr";
6548 my $expr = "\@_ >= " . ($ix+1) . " ? \$_[$ix] : ";
6549 my $def = $self->deparse($op->first, 7);
6550 $def = "($def)" if $op->first->flags & OPf_PARENS;
6551 $expr .= $self->deparse($op->first, $cx);
6561 B::Deparse - Perl compiler backend to produce perl code
6565 B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
6566 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
6570 B::Deparse is a backend module for the Perl compiler that generates
6571 perl source code, based on the internal compiled structure that perl
6572 itself creates after parsing a program. The output of B::Deparse won't
6573 be exactly the same as the original source, since perl doesn't keep
6574 track of comments or whitespace, and there isn't a one-to-one
6575 correspondence between perl's syntactical constructions and their
6576 compiled form, but it will often be close. When you use the B<-p>
6577 option, the output also includes parentheses even when they are not
6578 required by precedence, which can make it easy to see if perl is
6579 parsing your expressions the way you intended.
6581 While B::Deparse goes to some lengths to try to figure out what your
6582 original program was doing, some parts of the language can still trip
6583 it up; it still fails even on some parts of Perl's own test suite. If
6584 you encounter a failure other than the most common ones described in
6585 the BUGS section below, you can help contribute to B::Deparse's
6586 ongoing development by submitting a bug report with a small
6591 As with all compiler backend options, these must follow directly after
6592 the '-MO=Deparse', separated by a comma but not any white space.
6598 Output data values (when they appear as constants) using Data::Dumper.
6599 Without this option, B::Deparse will use some simple routines of its
6600 own for the same purpose. Currently, Data::Dumper is better for some
6601 kinds of data (such as complex structures with sharing and
6602 self-reference) while the built-in routines are better for others
6603 (such as odd floating-point values).
6607 Normally, B::Deparse deparses the main code of a program, and all the subs
6608 defined in the same file. To include subs defined in
6609 other files, pass the B<-f> option with the filename.
6610 You can pass the B<-f> option several times, to
6611 include more than one secondary file. (Most of the time you don't want to
6612 use it at all.) You can also use this option to include subs which are
6613 defined in the scope of a B<#line> directive with two parameters.
6617 Add '#line' declarations to the output based on the line and file
6618 locations of the original code.
6622 Print extra parentheses. Without this option, B::Deparse includes
6623 parentheses in its output only when they are needed, based on the
6624 structure of your program. With B<-p>, it uses parentheses (almost)
6625 whenever they would be legal. This can be useful if you are used to
6626 LISP, or if you want to see how perl parses your input. If you say
6628 if ($var & 0x7f == 65) {print "Gimme an A!"}
6629 print ($which ? $a : $b), "\n";
6630 $name = $ENV{USER} or "Bob";
6632 C<B::Deparse,-p> will print
6635 print('Gimme an A!')
6637 (print(($which ? $a : $b)), '???');
6638 (($name = $ENV{'USER'}) or '???')
6640 which probably isn't what you intended (the C<'???'> is a sign that
6641 perl optimized away a constant value).
6645 Disable prototype checking. With this option, all function calls are
6646 deparsed as if no prototype was defined for them. In other words,
6648 perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
6657 making clear how the parameters are actually passed to C<foo>.
6661 Expand double-quoted strings into the corresponding combinations of
6662 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
6665 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
6669 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
6670 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
6672 Note that the expanded form represents the way perl handles such
6673 constructions internally -- this option actually turns off the reverse
6674 translation that B::Deparse usually does. On the other hand, note that
6675 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
6676 of $y into a string before doing the assignment.
6678 =item B<-s>I<LETTERS>
6680 Tweak the style of B::Deparse's output. The letters should follow
6681 directly after the 's', with no space or punctuation. The following
6682 options are available:
6688 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
6705 The default is not to cuddle.
6709 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
6713 Use tabs for each 8 columns of indent. The default is to use only spaces.
6714 For instance, if the style options are B<-si4T>, a line that's indented
6715 3 times will be preceded by one tab and four spaces; if the options were
6716 B<-si8T>, the same line would be preceded by three tabs.
6718 =item B<v>I<STRING>B<.>
6720 Print I<STRING> for the value of a constant that can't be determined
6721 because it was optimized away (mnemonic: this happens when a constant
6722 is used in B<v>oid context). The end of the string is marked by a period.
6723 The string should be a valid perl expression, generally a constant.
6724 Note that unless it's a number, it probably needs to be quoted, and on
6725 a command line quotes need to be protected from the shell. Some
6726 conventional values include 0, 1, 42, '', 'foo', and
6727 'Useless use of constant omitted' (which may need to be
6728 B<-sv"'Useless use of constant omitted'.">
6729 or something similar depending on your shell). The default is '???'.
6730 If you're using B::Deparse on a module or other file that's require'd,
6731 you shouldn't use a value that evaluates to false, since the customary
6732 true constant at the end of a module will be in void context when the
6733 file is compiled as a main program.
6739 Expand conventional syntax constructions into equivalent ones that expose
6740 their internal operation. I<LEVEL> should be a digit, with higher values
6741 meaning more expansion. As with B<-q>, this actually involves turning off
6742 special cases in B::Deparse's normal operations.
6744 If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
6745 while loops with continue blocks; for instance
6747 for ($i = 0; $i < 10; ++$i) {
6760 Note that in a few cases this translation can't be perfectly carried back
6761 into the source code -- if the loop's initializer declares a my variable,
6762 for instance, it won't have the correct scope outside of the loop.
6764 If I<LEVEL> is at least 5, C<use> declarations will be translated into
6765 C<BEGIN> blocks containing calls to C<require> and C<import>; for
6775 'strict'->import('refs')
6779 If I<LEVEL> is at least 7, C<if> statements will be translated into
6780 equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
6782 print 'hi' if $nice;
6794 $nice and print 'hi';
6795 $nice and do { print 'hi' };
6796 $nice ? do { print 'hi' } : do { print 'bye' };
6798 Long sequences of elsifs will turn into nested ternary operators, which
6799 B::Deparse doesn't know how to indent nicely.
6803 =head1 USING B::Deparse AS A MODULE
6808 $deparse = B::Deparse->new("-p", "-sC");
6809 $body = $deparse->coderef2text(\&func);
6810 eval "sub func $body"; # the inverse operation
6814 B::Deparse can also be used on a sub-by-sub basis from other perl
6819 $deparse = B::Deparse->new(OPTIONS)
6821 Create an object to store the state of a deparsing operation and any
6822 options. The options are the same as those that can be given on the
6823 command line (see L</OPTIONS>); options that are separated by commas
6824 after B<-MO=Deparse> should be given as separate strings.
6826 =head2 ambient_pragmas
6828 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
6830 The compilation of a subroutine can be affected by a few compiler
6831 directives, B<pragmas>. These are:
6845 Assigning to the special variable $[
6865 Ordinarily, if you use B::Deparse on a subroutine which has
6866 been compiled in the presence of one or more of these pragmas,
6867 the output will include statements to turn on the appropriate
6868 directives. So if you then compile the code returned by coderef2text,
6869 it will behave the same way as the subroutine which you deparsed.
6871 However, you may know that you intend to use the results in a
6872 particular context, where some pragmas are already in scope. In
6873 this case, you use the B<ambient_pragmas> method to describe the
6874 assumptions you wish to make.
6876 Not all of the options currently have any useful effect. See
6877 L</BUGS> for more details.
6879 The parameters it accepts are:
6885 Takes a string, possibly containing several values separated
6886 by whitespace. The special values "all" and "none" mean what you'd
6889 $deparse->ambient_pragmas(strict => 'subs refs');
6893 Takes a number, the value of the array base $[.
6894 Obsolete: cannot be non-zero.
6902 If the value is true, then the appropriate pragma is assumed to
6903 be in the ambient scope, otherwise not.
6907 Takes a string, possibly containing a whitespace-separated list of
6908 values. The values "all" and "none" are special. It's also permissible
6909 to pass an array reference here.
6911 $deparser->ambient_pragmas(re => 'eval');
6916 Takes a string, possibly containing a whitespace-separated list of
6917 values. The values "all" and "none" are special, again. It's also
6918 permissible to pass an array reference here.
6920 $deparser->ambient_pragmas(warnings => [qw[void io]]);
6922 If one of the values is the string "FATAL", then all the warnings
6923 in that list will be considered fatal, just as with the B<warnings>
6924 pragma itself. Should you need to specify that some warnings are
6925 fatal, and others are merely enabled, you can pass the B<warnings>
6928 $deparser->ambient_pragmas(
6930 warnings => [FATAL => qw/void io/],
6933 See L<warnings> for more information about lexical warnings.
6939 These two parameters are used to specify the ambient pragmas in
6940 the format used by the special variables $^H and ${^WARNING_BITS}.
6942 They exist principally so that you can write code like:
6944 { my ($hint_bits, $warning_bits);
6945 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
6946 $deparser->ambient_pragmas (
6947 hint_bits => $hint_bits,
6948 warning_bits => $warning_bits,
6952 which specifies that the ambient pragmas are exactly those which
6953 are in scope at the point of calling.
6957 This parameter is used to specify the ambient pragmas which are
6958 stored in the special hash %^H.
6964 $body = $deparse->coderef2text(\&func)
6965 $body = $deparse->coderef2text(sub ($$) { ... })
6967 Return source code for the body of a subroutine (a block, optionally
6968 preceded by a prototype in parens), given a reference to the
6969 sub. Because a subroutine can have no names, or more than one name,
6970 this method doesn't return a complete subroutine definition -- if you
6971 want to eval the result, you should prepend "sub subname ", or "sub "
6972 for an anonymous function constructor. Unless the sub was defined in
6973 the main:: package, the code will include a package declaration.
6982 be completely supported are: C<use warnings>,
6983 C<use strict>, C<use bytes>, C<use integer>
6986 Excepting those listed above, we're currently unable to guarantee that
6987 B::Deparse will produce a pragma at the correct point in the program.
6988 (Specifically, pragmas at the beginning of a block often appear right
6989 before the start of the block instead.)
6990 Since the effects of pragmas are often lexically scoped, this can mean
6991 that the pragma holds sway over a different portion of the program
6992 than in the input file.
6996 In fact, the above is a specific instance of a more general problem:
6997 we can't guarantee to produce BEGIN blocks or C<use> declarations in
6998 exactly the right place. So if you use a module which affects compilation
6999 (such as by over-riding keywords, overloading constants or whatever)
7000 then the output code might not work as intended.
7004 Some constants don't print correctly either with or without B<-d>.
7005 For instance, neither B::Deparse nor Data::Dumper know how to print
7006 dual-valued scalars correctly, as in:
7008 use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
7010 use constant H => { "#" => 1 }; H->{"#"};
7014 An input file that uses source filtering probably won't be deparsed into
7015 runnable code, because it will still include the B<use> declaration
7016 for the source filtering module, even though the code that is
7017 produced is already ordinary Perl which shouldn't be filtered again.
7021 Optimized-away statements are rendered as
7022 '???'. This includes statements that
7023 have a compile-time side-effect, such as the obscure
7027 which is not, consequently, deparsed correctly.
7029 foreach my $i (@_) { 0 }
7031 foreach my $i (@_) { '???' }
7035 Lexical (my) variables declared in scopes external to a subroutine
7036 appear in coderef2text output text as package variables. This is a tricky
7037 problem, as perl has no native facility for referring to a lexical variable
7038 defined within a different scope, although L<PadWalker> is a good start.
7040 See also L<Data::Dump::Streamer>, which combines B::Deparse and
7041 L<PadWalker> to serialize closures properly.
7045 There are probably many more bugs on non-ASCII platforms (EBCDIC).
7051 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version
7052 by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from
7053 Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
7054 Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael