2 # Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved.
3 # This module is free software; you can redistribute and/or modify
4 # it under the same terms as Perl itself.
6 # This is based on the module of the same name by Malcolm Beattie,
7 # but essentially none of his code remains.
10 use Carp 'cluck', 'croak';
11 use B qw(class main_root main_start main_cv svref_2object opnumber cstring
12 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
13 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
14 OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
15 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
16 OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
18 SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR
19 CVf_METHOD CVf_LOCKED CVf_LVALUE
20 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
21 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
26 # Changes between 0.50 and 0.51:
27 # - fixed nulled leave with live enter in sort { }
28 # - fixed reference constants (\"str")
29 # - handle empty programs gracefully
30 # - handle infinte loops (for (;;) {}, while (1) {})
31 # - differentiate between `for my $x ...' and `my $x; for $x ...'
32 # - various minor cleanups
33 # - moved globals into an object
34 # - added `-u', like B::C
35 # - package declarations using cop_stash
36 # - subs, formats and code sorted by cop_seq
37 # Changes between 0.51 and 0.52:
38 # - added pp_threadsv (special variables under USE_5005THREADS)
39 # - added documentation
40 # Changes between 0.52 and 0.53:
41 # - many changes adding precedence contexts and associativity
42 # - added `-p' and `-s' output style options
43 # - various other minor fixes
44 # Changes between 0.53 and 0.54:
45 # - added support for new `for (1..100)' optimization,
47 # Changes between 0.54 and 0.55:
48 # - added support for new qr// construct
49 # - added support for new pp_regcreset OP
50 # Changes between 0.55 and 0.56:
51 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
52 # - fixed $# on non-lexicals broken in last big rewrite
53 # - added temporary fix for change in opcode of OP_STRINGIFY
54 # - fixed problem in 0.54's for() patch in `for (@ary)'
55 # - fixed precedence in conditional of ?:
56 # - tweaked list paren elimination in `my($x) = @_'
57 # - made continue-block detection trickier wrt. null ops
58 # - fixed various prototype problems in pp_entersub
59 # - added support for sub prototypes that never get GVs
60 # - added unquoting for special filehandle first arg in truncate
61 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
62 # - added semicolons at the ends of blocks
63 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
64 # Changes between 0.56 and 0.561:
65 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
66 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
67 # Changes between 0.561 and 0.57:
68 # - stylistic changes to symbolic constant stuff
69 # - handled scope in s///e replacement code
70 # - added unquote option for expanding "" into concats, etc.
71 # - split method and proto parts of pp_entersub into separate functions
72 # - various minor cleanups
74 # - added parens in \&foo (patch by Albert Dvornik)
75 # Changes between 0.57 and 0.58:
76 # - fixed `0' statements that weren't being printed
77 # - added methods for use from other programs
78 # (based on patches from James Duncan and Hugo van der Sanden)
79 # - added -si and -sT to control indenting (also based on a patch from Hugo)
80 # - added -sv to print something else instead of '???'
81 # - preliminary version of utf8 tr/// handling
83 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
84 # - added support for Hugo's new OP_SETSTATE (like nextstate)
85 # Changes between 0.58 and 0.59
86 # - added support for Chip's OP_METHOD_NAMED
87 # - added support for Ilya's OPpTARGET_MY optimization
88 # - elided arrows before `()' subscripts when possible
89 # Changes between 0.59 and 0.60
90 # - support for method attribues was added
91 # - some warnings fixed
92 # - separate recognition of constant subs
93 # - rewrote continue block handling, now recoginizing for loops
94 # - added more control of expanding control structures
95 # Changes between 0.60 and 0.61 (mostly by Robin Houston)
97 # - support for pragmas and 'use'
98 # - support for the little-used $[ variable
99 # - support for __DATA__ sections
101 # - BEGIN, CHECK, INIT and END blocks
102 # - scoping of subroutine declarations fixed
103 # - compile-time output from the input program can be suppressed, so that the
104 # output is just the deparsed code. (a change to O.pm in fact)
105 # - our() declarations
106 # - *all* the known bugs are now listed in the BUGS section
107 # - comprehensive test mechanism (TEST -deparse)
110 # (See also BUGS section at the end of this file)
112 # - finish tr/// changes
113 # - add option for even more parens (generalize \&foo change)
114 # - left/right context
115 # - treat top-level block specially for incremental output
116 # - copy comments (look at real text with $^P?)
117 # - avoid semis in one-statement blocks
118 # - associativity of &&=, ||=, ?:
119 # - ',' => '=>' (auto-unquote?)
120 # - break long lines ("\r" as discretionary break?)
121 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
122 # - more style options: brace style, hex vs. octal, quotes, ...
123 # - print big ints as hex/octal instead of decimal (heuristic?)
124 # - handle `my $x if 0'?
125 # - coordinate with Data::Dumper (both directions? see previous)
126 # - version using op_next instead of op_first/sibling?
127 # - avoid string copies (pass arrays, one big join?)
130 # Tests that will always fail:
131 # (see t/TEST for the short list)
133 # Object fields (were globals):
136 # (local($a), local($b)) and local($a, $b) have the same internal
137 # representation but the short form looks better. We notice we can
138 # use a large-scale local when checking the list, but need to prevent
139 # individual locals too. This hash holds the addresses of OPs that
140 # have already had their local-ness accounted for. The same thing
144 # CV for current sub (or main program) being deparsed
147 # Cached hash of lexical variables for curcv: keys are names,
148 # each value is an array of pairs, indicating the cop_seq of scopes
149 # in which a var of that name is valid.
152 # COP for statement being deparsed
155 # name of the current package for deparsed code
158 # array of [cop_seq, CV, is_format?] for subs and formats we still
162 # as above, but [name, prototype] for subs that never got a GV
164 # subs_done, forms_done:
165 # keys are addresses of GVs for subs and formats we've already
166 # deparsed (or at least put into subs_todo)
169 # keys are names of subs for which we've printed declarations.
170 # That means we can omit parentheses from the arguments.
175 # cuddle: ` ' or `\n', depending on -sC
180 # A little explanation of how precedence contexts and associativity
183 # deparse() calls each per-op subroutine with an argument $cx (short
184 # for context, but not the same as the cx* in the perl core), which is
185 # a number describing the op's parents in terms of precedence, whether
186 # they're inside an expression or at statement level, etc. (see
187 # chart below). When ops with children call deparse on them, they pass
188 # along their precedence. Fractional values are used to implement
189 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
190 # parentheses hacks. The major disadvantage of this scheme is that
191 # it doesn't know about right sides and left sides, so say if you
192 # assign a listop to a variable, it can't tell it's allowed to leave
193 # the parens off the listop.
196 # 26 [TODO] inside interpolation context ("")
197 # 25 left terms and list operators (leftward)
201 # 21 right ! ~ \ and unary + and -
206 # 16 nonassoc named unary operators
207 # 15 nonassoc < > <= >= lt gt le ge
208 # 14 nonassoc == != <=> eq ne cmp
215 # 7 right = += -= *= etc.
217 # 5 nonassoc list operators (rightward)
221 # 1 statement modifiers
224 # Also, lineseq may pass a fourth parameter to the pp_ routines:
225 # if present, the fourth parameter is passed on by deparse.
227 # If present and true, it means that the op exists directly as
228 # part of a lineseq. Currently it's only used by scopeop to
229 # decide whether its results need to be enclosed in a do {} block.
231 # Nonprinting characters with special meaning:
232 # \cS - steal parens (see maybe_parens_unop)
233 # \n - newline and indent
234 # \t - increase indent
235 # \b - decrease indent (`outdent')
236 # \f - flush left (no indent)
237 # \cK - kill following semicolon, if any
241 return class($op) eq "NULL";
246 my($cv, $is_form) = @_;
247 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
249 if (!null($cv->START) and is_state($cv->START)) {
250 $seq = $cv->START->cop_seq;
254 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
259 my $ent = shift @{$self->{'subs_todo'}};
262 my $name = $self->gv_name($gv);
264 return "format $name =\n"
265 . $self->deparse_format($ent->[1]). "\n";
267 $self->{'subs_declared'}{$name} = 1;
268 if ($name eq "BEGIN") {
269 my $use_dec = $self->begin_is_use($cv);
270 if (defined ($use_dec)) {
271 return () if 0 == length($use_dec);
276 if ($self->{'linenums'}) {
277 my $line = $gv->LINE;
278 my $file = $gv->FILE;
279 $l = "\n\f#line $line \"$file\"\n";
281 return "${l}sub $name " . $self->deparse_sub($cv);
285 # Return a "use" declaration for this BEGIN block, if appropriate
287 my ($self, $cv) = @_;
288 my $root = $cv->ROOT;
289 local @$self{qw'curcv curcvlex'} = ($cv);
291 #B::walkoptree($cv->ROOT, "debug");
292 my $lineseq = $root->first;
293 return if $lineseq->name ne "lineseq";
295 my $req_op = $lineseq->first->sibling;
296 return if $req_op->name ne "require";
299 if ($req_op->first->private & OPpCONST_BARE) {
300 # Actually it should always be a bareword
301 $module = $self->const_sv($req_op->first)->PV;
302 $module =~ s[/][::]g;
306 $module = const($self->const_sv($req_op->first));
310 my $version_op = $req_op->sibling;
311 return if class($version_op) eq "NULL";
312 if ($version_op->name eq "lineseq") {
313 # We have a version parameter; skip nextstate & pushmark
314 my $constop = $version_op->first->next->next;
316 return unless $self->const_sv($constop)->PV eq $module;
317 $constop = $constop->sibling;
318 $version = $self->const_sv($constop)->int_value;
319 $constop = $constop->sibling;
320 return if $constop->name ne "method_named";
321 return if $self->const_sv($constop)->PV ne "VERSION";
324 $lineseq = $version_op->sibling;
325 return if $lineseq->name ne "lineseq";
326 my $entersub = $lineseq->first->sibling;
327 if ($entersub->name eq "stub") {
328 return "use $module $version ();\n" if defined $version;
329 return "use $module ();\n";
331 return if $entersub->name ne "entersub";
333 # See if there are import arguments
336 my $svop = $entersub->first->sibling; # Skip over pushmark
337 return unless $self->const_sv($svop)->PV eq $module;
339 # Pull out the arguments
340 for ($svop=$svop->sibling; $svop->name ne "method_named";
341 $svop = $svop->sibling) {
342 $args .= ", " if length($args);
343 $args .= $self->deparse($svop, 6);
347 my $method_named = $svop;
348 return if $method_named->name ne "method_named";
349 my $method_name = $self->const_sv($method_named)->PV;
351 if ($method_name eq "unimport") {
355 # Certain pragmas are dealt with using hint bits,
356 # so we ignore them here
357 if ($module eq 'strict' || $module eq 'integer'
358 || $module eq 'bytes' || $module eq 'warnings') {
362 if (defined $version && length $args) {
363 return "$use $module $version ($args);\n";
364 } elsif (defined $version) {
365 return "$use $module $version;\n";
366 } elsif (length $args) {
367 return "$use $module ($args);\n";
369 return "$use $module;\n";
374 my ($self, $pack) = @_;
376 if (!defined $pack) {
381 $pack =~ s/(::)?$/::/;
385 my %stash = svref_2object($stash)->ARRAY;
386 while (my ($key, $val) = each %stash) {
387 next if $key eq 'main::'; # avoid infinite recursion
388 my $class = class($val);
389 if ($class eq "PV") {
390 # Just a prototype. As an ugly but fairly effective way
391 # to find out if it belongs here is to see if the AUTOLOAD
392 # (if any) for the stash was defined in one of our files.
393 my $A = $stash{"AUTOLOAD"};
394 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
395 && class($A->CV) eq "CV") {
397 next unless $AF eq $0 || exists $self->{'files'}{$AF};
399 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
400 } elsif ($class eq "IV") {
401 # Just a name. As above.
402 my $A = $stash{"AUTOLOAD"};
403 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
404 && class($A->CV) eq "CV") {
406 next unless $AF eq $0 || exists $self->{'files'}{$AF};
408 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
409 } elsif ($class eq "GV") {
410 if (class(my $cv = $val->CV) ne "SPECIAL") {
411 next if $self->{'subs_done'}{$$val}++;
412 next if $$val != ${$cv->GV}; # Ignore imposters
415 if (class(my $cv = $val->FORM) ne "SPECIAL") {
416 next if $self->{'forms_done'}{$$val}++;
417 next if $$val != ${$cv->GV}; # Ignore imposters
420 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
421 $self->stash_subs($pack . $key);
431 foreach $ar (@{$self->{'protos_todo'}}) {
432 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
433 push @ret, "sub " . $ar->[0] . "$proto;\n";
435 delete $self->{'protos_todo'};
443 while (length($opt = substr($opts, 0, 1))) {
445 $self->{'cuddle'} = " ";
446 $opts = substr($opts, 1);
447 } elsif ($opt eq "i") {
448 $opts =~ s/^i(\d+)//;
449 $self->{'indent_size'} = $1;
450 } elsif ($opt eq "T") {
451 $self->{'use_tabs'} = 1;
452 $opts = substr($opts, 1);
453 } elsif ($opt eq "v") {
454 $opts =~ s/^v([^.]*)(.|$)//;
455 $self->{'ex_const'} = $1;
462 my $self = bless {}, $class;
463 $self->{'subs_todo'} = [];
464 $self->{'files'} = {};
465 $self->{'curstash'} = "main";
466 $self->{'curcop'} = undef;
467 $self->{'cuddle'} = "\n";
468 $self->{'indent_size'} = 4;
469 $self->{'use_tabs'} = 0;
470 $self->{'expand'} = 0;
471 $self->{'unquote'} = 0;
472 $self->{'linenums'} = 0;
473 $self->{'parens'} = 0;
474 $self->{'ex_const'} = "'???'";
476 $self->{'ambient_arybase'} = 0;
477 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
478 $self->{'ambient_hints'} = 0;
481 while (my $arg = shift @_) {
482 if ($arg =~ /^-f(.*)/) {
483 $self->{'files'}{$1} = 1;
484 } elsif ($arg eq "-p") {
485 $self->{'parens'} = 1;
486 } elsif ($arg eq "-l") {
487 $self->{'linenums'} = 1;
488 } elsif ($arg eq "-q") {
489 $self->{'unquote'} = 1;
490 } elsif (substr($arg, 0, 2) eq "-s") {
491 $self->style_opts(substr $arg, 2);
492 } elsif ($arg =~ /^-x(\d)$/) {
493 $self->{'expand'} = $1;
500 # Mask out the bits that L<warnings::register> uses
503 $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
510 # Initialise the contextual information, either from
511 # defaults provided with the ambient_pragmas method,
512 # or from perl's own defaults otherwise.
516 $self->{'arybase'} = $self->{'ambient_arybase'};
517 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
518 ? $self->{'ambient_warnings'} & WARN_MASK
520 $self->{'hints'} = $self->{'ambient_hints'} & 0xFF;
522 # also a convenient place to clear out subs_declared
523 delete $self->{'subs_declared'};
529 my $self = B::Deparse->new(@args);
530 # First deparse command-line args
531 if (defined $^I) { # deparse -i
532 print q(BEGIN { $^I = ).cstring($^I).qq(; }\n);
534 if ($^W) { # deparse -w
535 print qq(BEGIN { \$^W = $^W; }\n);
537 if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
538 my $fs = cstring($/) || 'undef';
539 my $bs = cstring($O::savebackslash) || 'undef';
540 print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
542 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
543 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
544 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
545 for my $block (@BEGINs, @INITs, @ENDs) {
546 $self->todo($block, 0);
549 $self->{'curcv'} = main_cv;
550 $self->{'curcvlex'} = undef;
551 print $self->print_protos;
552 @{$self->{'subs_todo'}} =
553 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
554 print $self->indent($self->deparse(main_root, 0)), "\n"
555 unless null main_root;
557 while (scalar(@{$self->{'subs_todo'}})) {
558 push @text, $self->next_todo;
560 print $self->indent(join("", @text)), "\n" if @text;
562 # Print __DATA__ section, if necessary
564 if (defined *{$self->{'curstash'}."::DATA"}{IO}) {
566 print readline(*{$self->{'curstash'}."::DATA"});
574 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
577 return $self->indent($self->deparse_sub(svref_2object($sub)));
580 sub ambient_pragmas {
582 my ($arybase, $hint_bits, $warning_bits) = (0, 0);
588 if ($name eq 'strict') {
591 if ($val eq 'none') {
592 $hint_bits &= ~strict::bits(qw/refs subs vars/);
598 @names = qw/refs subs vars/;
604 @names = split' ', $val;
606 $hint_bits |= strict::bits(@names);
609 elsif ($name eq '$[') {
613 elsif ($name eq 'integer'
615 || $name eq 'utf8') {
618 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
621 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
625 elsif ($name eq 're') {
627 if ($val eq 'none') {
628 $hint_bits &= ~re::bits(qw/taint eval/);
634 @names = qw/taint eval/;
640 @names = split' ',$val;
642 $hint_bits |= re::bits(@names);
645 elsif ($name eq 'warnings') {
646 if ($val eq 'none') {
647 $warning_bits = $warnings::NONE;
656 @names = split/\s+/, $val;
659 $warning_bits = $warnings::NONE if !defined ($warning_bits);
660 $warning_bits |= warnings::bits(@names);
663 elsif ($name eq 'warning_bits') {
664 $warning_bits = $val;
667 elsif ($name eq 'hint_bits') {
672 croak "Unknown pragma type: $name";
676 croak "The ambient_pragmas method expects an even number of args";
679 $self->{'ambient_arybase'} = $arybase;
680 $self->{'ambient_warnings'} = $warning_bits;
681 $self->{'ambient_hints'} = $hint_bits;
686 my($op, $cx, $flags) = @_;
688 Carp::confess("Null op in deparse") if !defined($op)
689 || class($op) eq "NULL";
690 my $meth = "pp_" . $op->name;
692 return $self->$meth($op, $cx, $flags);
694 return $self->$meth($op, $cx);
700 my @lines = split(/\n/, $txt);
705 my $cmd = substr($line, 0, 1);
706 if ($cmd eq "\t" or $cmd eq "\b") {
707 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
708 if ($self->{'use_tabs'}) {
709 $leader = "\t" x ($level / 8) . " " x ($level % 8);
711 $leader = " " x $level;
713 $line = substr($line, 1);
715 if (substr($line, 0, 1) eq "\f") {
716 $line = substr($line, 1); # no indent
718 $line = $leader . $line;
722 return join("\n", @lines);
729 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
730 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
731 local $self->{'curcop'} = $self->{'curcop'};
732 if ($cv->FLAGS & SVf_POK) {
733 $proto = "(". $cv->PV . ") ";
735 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
737 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
738 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
739 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
742 local($self->{'curcv'}) = $cv;
743 local($self->{'curcvlex'});
744 local(@$self{qw'curstash warnings hints'})
745 = @$self{qw'curstash warnings hints'};
747 if (not null $cv->ROOT) {
748 my $lineseq = $cv->ROOT->first;
749 if ($lineseq->name eq "lineseq") {
751 for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
754 $body = $self->lineseq(undef, @ops).";";
755 my $scope_en = $self->find_scope_en($lineseq);
756 if (defined $scope_en) {
757 my $subs = join"", $self->seq_subs($scope_en);
758 $body .= ";\n$subs" if length($subs);
762 $body = $self->deparse($cv->ROOT->first, 0);
766 my $sv = $cv->const_sv;
768 # uh-oh. inlinable sub... format it differently
769 return $proto . "{ " . const($sv) . " }\n";
770 } else { # XSUB? (or just a declaration)
774 return $proto ."{\n\t$body\n\b}" ."\n";
781 local($self->{'curcv'}) = $form;
782 local($self->{'curcvlex'});
783 local($self->{'in_format'}) = 1;
784 local(@$self{qw'curstash warnings hints'})
785 = @$self{qw'curstash warnings hints'};
786 my $op = $form->ROOT;
788 return "\f." if $op->first->name eq 'stub';
789 $op = $op->first->first; # skip leavewrite, lineseq
790 while (not null $op) {
791 $op = $op->sibling; # skip nextstate
793 $kid = $op->first->sibling; # skip pushmark
794 push @text, "\f".$self->const_sv($kid)->PV;
795 $kid = $kid->sibling;
796 for (; not null $kid; $kid = $kid->sibling) {
797 push @exprs, $self->deparse($kid, 0);
799 push @text, "\f".join(", ", @exprs)."\n" if @exprs;
802 return join("", @text) . "\f.";
807 return $op->name eq "leave" || $op->name eq "scope"
808 || $op->name eq "lineseq"
809 || ($op->name eq "null" && class($op) eq "UNOP"
810 && (is_scope($op->first) || $op->first->name eq "enter"));
814 my $name = $_[0]->name;
815 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
818 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
820 return (!null($op) and null($op->sibling)
821 and $op->name eq "null" and class($op) eq "UNOP"
822 and (($op->first->name =~ /^(and|or)$/
823 and $op->first->first->sibling->name eq "lineseq")
824 or ($op->first->name eq "lineseq"
825 and not null $op->first->first->sibling
826 and $op->first->first->sibling->name eq "unstack")
832 return ($op->name eq "rv2sv" or
833 $op->name eq "padsv" or
834 $op->name eq "gv" or # only in array/hash constructs
835 $op->flags & OPf_KIDS && !null($op->first)
836 && $op->first->name eq "gvsv");
841 my($text, $cx, $prec) = @_;
842 if ($prec < $cx # unary ops nest just fine
843 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
844 or $self->{'parens'})
847 # In a unop, let parent reuse our parens; see maybe_parens_unop
848 $text = "\cS" . $text if $cx == 16;
855 # same as above, but get around the `if it looks like a function' rule
856 sub maybe_parens_unop {
858 my($name, $kid, $cx) = @_;
859 if ($cx > 16 or $self->{'parens'}) {
860 $kid = $self->deparse($kid, 1);
861 if ($name eq "umask" && $kid =~ /^\d+$/) {
862 $kid = sprintf("%#o", $kid);
864 return "$name($kid)";
866 $kid = $self->deparse($kid, 16);
867 if ($name eq "umask" && $kid =~ /^\d+$/) {
868 $kid = sprintf("%#o", $kid);
870 if (substr($kid, 0, 1) eq "\cS") {
872 return $name . substr($kid, 1);
873 } elsif (substr($kid, 0, 1) eq "(") {
874 # avoid looks-like-a-function trap with extra parens
875 # (`+' can lead to ambiguities)
876 return "$name(" . $kid . ")";
883 sub maybe_parens_func {
885 my($func, $text, $cx, $prec) = @_;
886 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
887 return "$func($text)";
889 return "$func $text";
895 my($op, $cx, $text) = @_;
896 my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
897 if ($op->private & (OPpLVAL_INTRO|$our_intro)
898 and not $self->{'avoid_local'}{$$op}) {
899 my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
900 if (want_scalar($op)) {
901 return "$our_local $text";
903 return $self->maybe_parens_func("$our_local", $text, $cx, 16);
912 my($op, $cx, $func, @args) = @_;
913 if ($op->private & OPpTARGET_MY) {
914 my $var = $self->padname($op->targ);
915 my $val = $func->($self, $op, 7, @args);
916 return $self->maybe_parens("$var = $val", $cx, 7);
918 return $func->($self, $op, $cx, @args);
925 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
930 my($op, $cx, $text) = @_;
931 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
932 if (want_scalar($op)) {
935 return $self->maybe_parens_func("my", $text, $cx, 16);
942 # The following OPs don't have functions:
944 # pp_padany -- does not exist after parsing
946 sub pp_enter { # see also leave
947 cluck "unexpected OP_ENTER";
951 sub pp_pushmark { # see also list
952 cluck "unexpected OP_PUSHMARK";
956 sub pp_leavesub { # see also deparse_sub
957 cluck "unexpected OP_LEAVESUB";
961 sub pp_leavewrite { # see also deparse_format
962 cluck "unexpected OP_LEAVEWRITE";
966 sub pp_method { # see also entersub
967 cluck "unexpected OP_METHOD";
971 sub pp_regcmaybe { # see also regcomp
972 cluck "unexpected OP_REGCMAYBE";
976 sub pp_regcreset { # see also regcomp
977 cluck "unexpected OP_REGCRESET";
981 sub pp_substcont { # see also subst
982 cluck "unexpected OP_SUBSTCONT";
986 sub pp_grepstart { # see also grepwhile
987 cluck "unexpected OP_GREPSTART";
991 sub pp_mapstart { # see also mapwhile
992 cluck "unexpected OP_MAPSTART";
996 sub pp_method_named {
997 cluck "unexpected OP_METHOD_NAMED";
1001 sub pp_flip { # see also flop
1002 cluck "unexpected OP_FLIP";
1006 sub pp_iter { # see also leaveloop
1007 cluck "unexpected OP_ITER";
1011 sub pp_enteriter { # see also leaveloop
1012 cluck "unexpected OP_ENTERITER";
1016 sub pp_enterloop { # see also leaveloop
1017 cluck "unexpected OP_ENTERLOOP";
1021 sub pp_leaveeval { # see also entereval
1022 cluck "unexpected OP_LEAVEEVAL";
1026 sub pp_entertry { # see also leavetry
1027 cluck "unexpected OP_ENTERTRY";
1031 # $root should be the op which represents the root of whatever
1032 # we're sequencing here. If it's undefined, then we don't append
1033 # any subroutine declarations to the deparsed ops, otherwise we
1034 # append appropriate declarations.
1036 my($self, $root, @ops) = @_;
1039 my $out_cop = $self->{'curcop'};
1040 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1042 if (defined $root) {
1043 $limit_seq = $out_seq;
1044 my $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
1045 $limit_seq = $nseq if !defined($limit_seq)
1046 or defined($nseq) && $nseq < $limit_seq;
1048 $limit_seq = $self->{'limit_seq'}
1049 if defined($self->{'limit_seq'})
1050 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1051 local $self->{'limit_seq'} = $limit_seq;
1052 for (my $i = 0; $i < @ops; $i++) {
1054 if (is_state $ops[$i]) {
1055 $expr = $self->deparse($ops[$i], 0);
1062 if (!is_state $ops[$i] and (my $ls = $ops[$i+1]) and
1063 !null($ops[$i+1]) and $ops[$i+1]->name eq "lineseq")
1065 if ($ls->first && !null($ls->first) && is_state($ls->first)
1066 && (my $sib = $ls->first->sibling)) {
1067 if (!null($sib) && $sib->name eq "leaveloop") {
1068 push @exprs, $expr . $self->for_loop($ops[$i], 0);
1074 $expr .= $self->deparse($ops[$i], 0, (@ops != 1));
1075 $expr =~ s/;\n?\z//;
1078 my $body = join(";\n", grep {length} @exprs);
1080 if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
1081 $subs = join "\n", $self->seq_subs($limit_seq);
1083 return join(";\n", grep {length} $body, $subs);
1087 my($real_block, $self, $op, $cx, $flags) = @_;
1091 local(@$self{qw'curstash warnings hints'})
1092 = @$self{qw'curstash warnings hints'} if $real_block;
1094 $kid = $op->first->sibling; # skip enter
1095 if (is_miniwhile($kid)) {
1096 my $top = $kid->first;
1097 my $name = $top->name;
1098 if ($name eq "and") {
1100 } elsif ($name eq "or") {
1102 } else { # no conditional -> while 1 or until 0
1103 return $self->deparse($top->first, 1) . " while 1";
1105 my $cond = $top->first;
1106 my $body = $cond->sibling->first; # skip lineseq
1107 $cond = $self->deparse($cond, 1);
1108 $body = $self->deparse($body, 1);
1109 return "$body $name $cond";
1114 for (; !null($kid); $kid = $kid->sibling) {
1117 if ($flags || $cx > 0) { # inside an expression, (a do {} while for lineseq)
1118 return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
1120 my $lineseq = $self->lineseq($op, @kids);
1121 return (length ($lineseq) ? "$lineseq;" : "");
1125 sub pp_scope { scopeop(0, @_); }
1126 sub pp_lineseq { scopeop(0, @_); }
1127 sub pp_leave { scopeop(1, @_); }
1129 # The BEGIN {} is used here because otherwise this code isn't executed
1130 # when you run B::Deparse on itself.
1132 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1133 "ENV", "ARGV", "ARGVOUT", "_"); }
1138 Carp::confess() if $gv->isa("B::CV");
1139 my $stash = $gv->STASH->NAME;
1140 my $name = $gv->SAFENAME;
1141 if ($stash eq $self->{'curstash'} or $globalnames{$name}
1142 or $name =~ /^[^A-Za-z_]/)
1146 $stash = $stash . "::";
1148 if ($name =~ /^(\^..|{)/) {
1149 $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
1151 return $stash . $name;
1154 # Return the name to use for a stash variable.
1155 # If a lexical with the same name is in scope, it may need to be
1157 sub stash_variable {
1158 my ($self, $prefix, $name) = @_;
1160 return "$prefix$name" if $name =~ /::/;
1162 unless ($prefix eq '$' || $prefix eq '@' ||
1163 $prefix eq '%' || $prefix eq '$#') {
1164 return "$prefix$name";
1167 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1168 return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
1169 return "$prefix$name";
1173 my ($self, $name) = @_;
1174 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1176 return 0 if !defined($self->{'curcop'});
1177 my $seq = $self->{'curcop'}->cop_seq;
1178 return 0 if !exists $self->{'curcvlex'}{$name};
1179 for my $a (@{$self->{'curcvlex'}{$name}}) {
1180 my ($st, $en) = @$a;
1181 return 1 if $seq > $st && $seq <= $en;
1186 sub populate_curcvlex {
1188 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1189 my @padlist = $cv->PADLIST->ARRAY;
1190 my @ns = $padlist[0]->ARRAY;
1192 for (my $i=0; $i<@ns; ++$i) {
1193 next if class($ns[$i]) eq "SPECIAL";
1194 next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars
1195 if (class($ns[$i]) eq "PV") {
1196 # Probably that pesky lexical @_
1199 my $name = $ns[$i]->PVX;
1200 my $seq_st = $ns[$i]->NVX;
1201 my $seq_en = int($ns[$i]->IVX);
1203 push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
1208 sub find_scope_st { ((find_scope(@_))[0]); }
1209 sub find_scope_en { ((find_scope(@_))[1]); }
1211 # Recurses down the tree, looking for pad variable introductions and COPs
1213 my ($self, $op, $scope_st, $scope_en) = @_;
1214 Carp::cluck() if !defined $op;
1215 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1217 for (my $o=$op->first; $$o; $o=$o->sibling) {
1218 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1219 my $s = int($self->padname_sv($o->targ)->NVX);
1220 my $e = $self->padname_sv($o->targ)->IVX;
1221 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1222 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1224 elsif (is_state($o)) {
1225 my $c = $o->cop_seq;
1226 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1227 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1229 elsif ($o->flags & OPf_KIDS) {
1230 ($scope_st, $scope_en) =
1231 $self->find_scope($o, $scope_st, $scope_en)
1235 return ($scope_st, $scope_en);
1238 # Returns a list of subs which should be inserted before the COP
1240 my ($self, $op, $out_seq) = @_;
1241 my $seq = $op->cop_seq;
1242 # If we have nephews, then our sequence number indicates
1243 # the cop_seq of the end of some sort of scope.
1244 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1245 and my $nseq = $self->find_scope_st($op->sibling) ) {
1248 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1249 return $self->seq_subs($seq);
1253 my ($self, $seq) = @_;
1255 #push @text, "# ($seq)\n";
1257 return "" if !defined $seq;
1258 while (scalar(@{$self->{'subs_todo'}})
1259 and $seq > $self->{'subs_todo'}[0][0]) {
1260 push @text, $self->next_todo;
1265 # Notice how subs and formats are inserted between statements here;
1266 # also $[ assignments and pragmas.
1270 $self->{'curcop'} = $op;
1272 push @text, $self->cop_subs($op);
1273 push @text, $op->label . ": " if $op->label;
1274 my $stash = $op->stashpv;
1275 if ($stash ne $self->{'curstash'}) {
1276 push @text, "package $stash;\n";
1277 $self->{'curstash'} = $stash;
1279 if ($self->{'linenums'}) {
1280 push @text, "\f#line " . $op->line .
1281 ' "' . $op->file, qq'"\n';
1284 if ($self->{'arybase'} != $op->arybase) {
1285 push @text, '$[ = '. $op->arybase .";\n";
1286 $self->{'arybase'} = $op->arybase;
1289 my $warnings = $op->warnings;
1291 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1292 $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
1294 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1295 $warning_bits = $warnings::NONE;
1297 elsif ($warnings->isa("B::SPECIAL")) {
1298 $warning_bits = undef;
1301 $warning_bits = $warnings->PV & WARN_MASK;
1304 if (defined ($warning_bits) and
1305 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1306 push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1307 $self->{'warnings'} = $warning_bits;
1310 if ($self->{'hints'} != $op->private) {
1311 push @text, declare_hints($self->{'hints'}, $op->private);
1312 $self->{'hints'} = $op->private;
1315 return join("", @text);
1318 sub declare_warnings {
1319 my ($from, $to) = @_;
1320 if (($to & WARN_MASK) eq warnings::bits("all")) {
1321 return "use warnings;\n";
1323 elsif (($to & WARN_MASK) eq "\0"x length($to)) {
1324 return "no warnings;\n";
1326 return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n";
1330 my ($from, $to) = @_;
1331 my $use = $to & ~$from;
1332 my $no = $from & ~$to;
1334 for my $pragma (hint_pragmas($use)) {
1335 $decls .= "use $pragma;\n";
1337 for my $pragma (hint_pragmas($no)) {
1338 $decls .= "no $pragma;\n";
1346 push @pragmas, "integer" if $bits & 0x1;
1347 push @pragmas, "strict 'refs'" if $bits & 0x2;
1348 push @pragmas, "bytes" if $bits & 0x8;
1352 sub pp_dbstate { pp_nextstate(@_) }
1353 sub pp_setstate { pp_nextstate(@_) }
1355 sub pp_unstack { return "" } # see also leaveloop
1359 my($op, $cx, $name) = @_;
1365 my($op, $cx, $name) = @_;
1373 sub pp_wantarray { baseop(@_, "wantarray") }
1374 sub pp_fork { baseop(@_, "fork") }
1375 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1376 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1377 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1378 sub pp_tms { baseop(@_, "times") }
1379 sub pp_ghostent { baseop(@_, "gethostent") }
1380 sub pp_gnetent { baseop(@_, "getnetent") }
1381 sub pp_gprotoent { baseop(@_, "getprotoent") }
1382 sub pp_gservent { baseop(@_, "getservent") }
1383 sub pp_ehostent { baseop(@_, "endhostent") }
1384 sub pp_enetent { baseop(@_, "endnetent") }
1385 sub pp_eprotoent { baseop(@_, "endprotoent") }
1386 sub pp_eservent { baseop(@_, "endservent") }
1387 sub pp_gpwent { baseop(@_, "getpwent") }
1388 sub pp_spwent { baseop(@_, "setpwent") }
1389 sub pp_epwent { baseop(@_, "endpwent") }
1390 sub pp_ggrent { baseop(@_, "getgrent") }
1391 sub pp_sgrent { baseop(@_, "setgrent") }
1392 sub pp_egrent { baseop(@_, "endgrent") }
1393 sub pp_getlogin { baseop(@_, "getlogin") }
1395 sub POSTFIX () { 1 }
1397 # I couldn't think of a good short name, but this is the category of
1398 # symbolic unary operators with interesting precedence
1402 my($op, $cx, $name, $prec, $flags) = (@_, 0);
1403 my $kid = $op->first;
1404 $kid = $self->deparse($kid, $prec);
1405 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1409 sub pp_preinc { pfixop(@_, "++", 23) }
1410 sub pp_predec { pfixop(@_, "--", 23) }
1411 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1412 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1413 sub pp_i_preinc { pfixop(@_, "++", 23) }
1414 sub pp_i_predec { pfixop(@_, "--", 23) }
1415 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1416 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1417 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1419 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1423 if ($op->first->name =~ /^(i_)?negate$/) {
1425 $self->pfixop($op, $cx, "-", 21.5);
1427 $self->pfixop($op, $cx, "-", 21);
1430 sub pp_i_negate { pp_negate(@_) }
1436 $self->pfixop($op, $cx, "not ", 4);
1438 $self->pfixop($op, $cx, "!", 21);
1444 my($op, $cx, $name) = @_;
1446 if ($op->flags & OPf_KIDS) {
1448 if (defined prototype("CORE::$name")
1449 && prototype("CORE::$name") =~ /^;?\*/
1450 && $kid->name eq "rv2gv") {
1454 return $self->maybe_parens_unop($name, $kid, $cx);
1456 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1460 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1461 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1462 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1463 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1464 sub pp_defined { unop(@_, "defined") }
1465 sub pp_undef { unop(@_, "undef") }
1466 sub pp_study { unop(@_, "study") }
1467 sub pp_ref { unop(@_, "ref") }
1468 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1470 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1471 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1472 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1473 sub pp_srand { unop(@_, "srand") }
1474 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1475 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1476 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1477 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1478 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1479 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1480 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1482 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1483 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1484 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1486 sub pp_each { unop(@_, "each") }
1487 sub pp_values { unop(@_, "values") }
1488 sub pp_keys { unop(@_, "keys") }
1489 sub pp_pop { unop(@_, "pop") }
1490 sub pp_shift { unop(@_, "shift") }
1492 sub pp_caller { unop(@_, "caller") }
1493 sub pp_reset { unop(@_, "reset") }
1494 sub pp_exit { unop(@_, "exit") }
1495 sub pp_prototype { unop(@_, "prototype") }
1497 sub pp_close { unop(@_, "close") }
1498 sub pp_fileno { unop(@_, "fileno") }
1499 sub pp_umask { unop(@_, "umask") }
1500 sub pp_untie { unop(@_, "untie") }
1501 sub pp_tied { unop(@_, "tied") }
1502 sub pp_dbmclose { unop(@_, "dbmclose") }
1503 sub pp_getc { unop(@_, "getc") }
1504 sub pp_eof { unop(@_, "eof") }
1505 sub pp_tell { unop(@_, "tell") }
1506 sub pp_getsockname { unop(@_, "getsockname") }
1507 sub pp_getpeername { unop(@_, "getpeername") }
1509 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1510 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1511 sub pp_readlink { unop(@_, "readlink") }
1512 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1513 sub pp_readdir { unop(@_, "readdir") }
1514 sub pp_telldir { unop(@_, "telldir") }
1515 sub pp_rewinddir { unop(@_, "rewinddir") }
1516 sub pp_closedir { unop(@_, "closedir") }
1517 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1518 sub pp_localtime { unop(@_, "localtime") }
1519 sub pp_gmtime { unop(@_, "gmtime") }
1520 sub pp_alarm { unop(@_, "alarm") }
1521 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1523 sub pp_dofile { unop(@_, "do") }
1524 sub pp_entereval { unop(@_, "eval") }
1526 sub pp_ghbyname { unop(@_, "gethostbyname") }
1527 sub pp_gnbyname { unop(@_, "getnetbyname") }
1528 sub pp_gpbyname { unop(@_, "getprotobyname") }
1529 sub pp_shostent { unop(@_, "sethostent") }
1530 sub pp_snetent { unop(@_, "setnetent") }
1531 sub pp_sprotoent { unop(@_, "setprotoent") }
1532 sub pp_sservent { unop(@_, "setservent") }
1533 sub pp_gpwnam { unop(@_, "getpwnam") }
1534 sub pp_gpwuid { unop(@_, "getpwuid") }
1535 sub pp_ggrnam { unop(@_, "getgrnam") }
1536 sub pp_ggrgid { unop(@_, "getgrgid") }
1538 sub pp_lock { unop(@_, "lock") }
1544 if ($op->private & OPpEXISTS_SUB) {
1545 # Checking for the existence of a subroutine
1546 return $self->maybe_parens_func("exists",
1547 $self->pp_rv2cv($op->first, 16), $cx, 16);
1549 if ($op->flags & OPf_SPECIAL) {
1550 # Array element, not hash element
1551 return $self->maybe_parens_func("exists",
1552 $self->pp_aelem($op->first, 16), $cx, 16);
1554 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1562 if ($op->private & OPpSLICE) {
1563 if ($op->flags & OPf_SPECIAL) {
1564 # Deleting from an array, not a hash
1565 return $self->maybe_parens_func("delete",
1566 $self->pp_aslice($op->first, 16),
1569 return $self->maybe_parens_func("delete",
1570 $self->pp_hslice($op->first, 16),
1573 if ($op->flags & OPf_SPECIAL) {
1574 # Deleting from an array, not a hash
1575 return $self->maybe_parens_func("delete",
1576 $self->pp_aelem($op->first, 16),
1579 return $self->maybe_parens_func("delete",
1580 $self->pp_helem($op->first, 16),
1588 if (class($op) eq "UNOP" and $op->first->name eq "const"
1589 and $op->first->private & OPpCONST_BARE)
1591 my $name = $self->const_sv($op->first)->PV;
1594 return "require $name";
1596 $self->unop($op, $cx, "require");
1603 my $kid = $op->first;
1604 if (not null $kid->sibling) {
1605 # XXX Was a here-doc
1606 return $self->dquote($op);
1608 $self->unop(@_, "scalar");
1615 #cluck "curcv was undef" unless $self->{curcv};
1616 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1622 my $kid = $op->first;
1623 if ($kid->name eq "null") {
1625 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1626 my($pre, $post) = @{{"anonlist" => ["[","]"],
1627 "anonhash" => ["{","}"]}->{$kid->name}};
1629 $kid = $kid->first->sibling; # skip pushmark
1630 for (; !null($kid); $kid = $kid->sibling) {
1631 $expr = $self->deparse($kid, 6);
1634 return $pre . join(", ", @exprs) . $post;
1635 } elsif (!null($kid->sibling) and
1636 $kid->sibling->name eq "anoncode") {
1638 $self->deparse_sub($self->padval($kid->sibling->targ));
1639 } elsif ($kid->name eq "pushmark") {
1640 my $sib_name = $kid->sibling->name;
1641 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1642 and not $kid->sibling->flags & OPf_REF)
1644 # The @a in \(@a) isn't in ref context, but only when the
1646 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1647 } elsif ($sib_name eq 'entersub') {
1648 my $text = $self->deparse($kid->sibling, 1);
1649 # Always show parens for \(&func()), but only with -p otherwise
1650 $text = "($text)" if $self->{'parens'}
1651 or $kid->sibling->private & OPpENTERSUB_AMPER;
1656 $self->pfixop($op, $cx, "\\", 20);
1659 sub pp_srefgen { pp_refgen(@_) }
1664 my $kid = $op->first;
1665 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1666 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
1667 return $self->unop($op, $cx, "readline");
1673 return "<" . $self->gv_name($op->gv) . ">";
1676 # Unary operators that can occur as pseudo-listops inside double quotes
1679 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1681 if ($op->flags & OPf_KIDS) {
1683 # If there's more than one kid, the first is an ex-pushmark.
1684 $kid = $kid->sibling if not null $kid->sibling;
1685 return $self->maybe_parens_unop($name, $kid, $cx);
1687 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1691 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1692 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1693 sub pp_uc { dq_unop(@_, "uc") }
1694 sub pp_lc { dq_unop(@_, "lc") }
1695 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1699 my ($op, $cx, $name) = @_;
1700 if (class($op) eq "PVOP") {
1701 return "$name " . $op->pv;
1702 } elsif (class($op) eq "OP") {
1704 } elsif (class($op) eq "UNOP") {
1705 # Note -- loop exits are actually exempt from the
1706 # looks-like-a-func rule, but a few extra parens won't hurt
1707 return $self->maybe_parens_unop($name, $op->first, $cx);
1711 sub pp_last { loopex(@_, "last") }
1712 sub pp_next { loopex(@_, "next") }
1713 sub pp_redo { loopex(@_, "redo") }
1714 sub pp_goto { loopex(@_, "goto") }
1715 sub pp_dump { loopex(@_, "dump") }
1719 my($op, $cx, $name) = @_;
1720 if (class($op) eq "UNOP") {
1721 # Genuine `-X' filetests are exempt from the LLAFR, but not
1722 # l?stat(); for the sake of clarity, give'em all parens
1723 return $self->maybe_parens_unop($name, $op->first, $cx);
1724 } elsif (class($op) eq "SVOP") {
1725 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1726 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1731 sub pp_lstat { ftst(@_, "lstat") }
1732 sub pp_stat { ftst(@_, "stat") }
1733 sub pp_ftrread { ftst(@_, "-R") }
1734 sub pp_ftrwrite { ftst(@_, "-W") }
1735 sub pp_ftrexec { ftst(@_, "-X") }
1736 sub pp_fteread { ftst(@_, "-r") }
1737 sub pp_ftewrite { ftst(@_, "-w") }
1738 sub pp_fteexec { ftst(@_, "-x") }
1739 sub pp_ftis { ftst(@_, "-e") }
1740 sub pp_fteowned { ftst(@_, "-O") }
1741 sub pp_ftrowned { ftst(@_, "-o") }
1742 sub pp_ftzero { ftst(@_, "-z") }
1743 sub pp_ftsize { ftst(@_, "-s") }
1744 sub pp_ftmtime { ftst(@_, "-M") }
1745 sub pp_ftatime { ftst(@_, "-A") }
1746 sub pp_ftctime { ftst(@_, "-C") }
1747 sub pp_ftsock { ftst(@_, "-S") }
1748 sub pp_ftchr { ftst(@_, "-c") }
1749 sub pp_ftblk { ftst(@_, "-b") }
1750 sub pp_ftfile { ftst(@_, "-f") }
1751 sub pp_ftdir { ftst(@_, "-d") }
1752 sub pp_ftpipe { ftst(@_, "-p") }
1753 sub pp_ftlink { ftst(@_, "-l") }
1754 sub pp_ftsuid { ftst(@_, "-u") }
1755 sub pp_ftsgid { ftst(@_, "-g") }
1756 sub pp_ftsvtx { ftst(@_, "-k") }
1757 sub pp_fttty { ftst(@_, "-t") }
1758 sub pp_fttext { ftst(@_, "-T") }
1759 sub pp_ftbinary { ftst(@_, "-B") }
1761 sub SWAP_CHILDREN () { 1 }
1762 sub ASSIGN () { 2 } # has OP= variant
1763 sub LIST_CONTEXT () { 4 } # Assignment is in list context
1769 my $name = $op->name;
1770 if ($name eq "concat" and $op->first->name eq "concat") {
1771 # avoid spurious `=' -- see comment in pp_concat
1774 if ($name eq "null" and class($op) eq "UNOP"
1775 and $op->first->name =~ /^(and|x?or)$/
1776 and null $op->first->sibling)
1778 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1779 # with a null that's used as the common end point of the two
1780 # flows of control. For precedence purposes, ignore it.
1781 # (COND_EXPRs have these too, but we don't bother with
1782 # their associativity).
1783 return assoc_class($op->first);
1785 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1788 # Left associative operators, like `+', for which
1789 # $a + $b + $c is equivalent to ($a + $b) + $c
1792 %left = ('multiply' => 19, 'i_multiply' => 19,
1793 'divide' => 19, 'i_divide' => 19,
1794 'modulo' => 19, 'i_modulo' => 19,
1796 'add' => 18, 'i_add' => 18,
1797 'subtract' => 18, 'i_subtract' => 18,
1799 'left_shift' => 17, 'right_shift' => 17,
1801 'bit_or' => 12, 'bit_xor' => 12,
1803 'or' => 2, 'xor' => 2,
1807 sub deparse_binop_left {
1809 my($op, $left, $prec) = @_;
1810 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1811 and $left{assoc_class($op)} == $left{assoc_class($left)})
1813 return $self->deparse($left, $prec - .00001);
1815 return $self->deparse($left, $prec);
1819 # Right associative operators, like `=', for which
1820 # $a = $b = $c is equivalent to $a = ($b = $c)
1823 %right = ('pow' => 22,
1824 'sassign=' => 7, 'aassign=' => 7,
1825 'multiply=' => 7, 'i_multiply=' => 7,
1826 'divide=' => 7, 'i_divide=' => 7,
1827 'modulo=' => 7, 'i_modulo=' => 7,
1829 'add=' => 7, 'i_add=' => 7,
1830 'subtract=' => 7, 'i_subtract=' => 7,
1832 'left_shift=' => 7, 'right_shift=' => 7,
1834 'bit_or=' => 7, 'bit_xor=' => 7,
1840 sub deparse_binop_right {
1842 my($op, $right, $prec) = @_;
1843 if ($right{assoc_class($op)} && $right{assoc_class($right)}
1844 and $right{assoc_class($op)} == $right{assoc_class($right)})
1846 return $self->deparse($right, $prec - .00001);
1848 return $self->deparse($right, $prec);
1854 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1855 my $left = $op->first;
1856 my $right = $op->last;
1858 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1862 if ($flags & SWAP_CHILDREN) {
1863 ($left, $right) = ($right, $left);
1865 $left = $self->deparse_binop_left($op, $left, $prec);
1866 $left = "($left)" if $flags & LIST_CONTEXT
1867 && $left !~ /^(my|our|local|)[\@\(]/;
1868 $right = $self->deparse_binop_right($op, $right, $prec);
1869 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1872 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1873 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1874 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1875 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1876 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1877 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1878 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1879 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1880 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1881 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1882 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1884 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1885 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1886 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1887 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1888 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1890 sub pp_eq { binop(@_, "==", 14) }
1891 sub pp_ne { binop(@_, "!=", 14) }
1892 sub pp_lt { binop(@_, "<", 15) }
1893 sub pp_gt { binop(@_, ">", 15) }
1894 sub pp_ge { binop(@_, ">=", 15) }
1895 sub pp_le { binop(@_, "<=", 15) }
1896 sub pp_ncmp { binop(@_, "<=>", 14) }
1897 sub pp_i_eq { binop(@_, "==", 14) }
1898 sub pp_i_ne { binop(@_, "!=", 14) }
1899 sub pp_i_lt { binop(@_, "<", 15) }
1900 sub pp_i_gt { binop(@_, ">", 15) }
1901 sub pp_i_ge { binop(@_, ">=", 15) }
1902 sub pp_i_le { binop(@_, "<=", 15) }
1903 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1905 sub pp_seq { binop(@_, "eq", 14) }
1906 sub pp_sne { binop(@_, "ne", 14) }
1907 sub pp_slt { binop(@_, "lt", 15) }
1908 sub pp_sgt { binop(@_, "gt", 15) }
1909 sub pp_sge { binop(@_, "ge", 15) }
1910 sub pp_sle { binop(@_, "le", 15) }
1911 sub pp_scmp { binop(@_, "cmp", 14) }
1913 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1914 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
1916 # `.' is special because concats-of-concats are optimized to save copying
1917 # by making all but the first concat stacked. The effect is as if the
1918 # programmer had written `($a . $b) .= $c', except legal.
1919 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1923 my $left = $op->first;
1924 my $right = $op->last;
1927 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1931 $left = $self->deparse_binop_left($op, $left, $prec);
1932 $right = $self->deparse_binop_right($op, $right, $prec);
1933 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1936 # `x' is weird when the left arg is a list
1940 my $left = $op->first;
1941 my $right = $op->last;
1944 if ($op->flags & OPf_STACKED) {
1948 if (null($right)) { # list repeat; count is inside left-side ex-list
1949 my $kid = $left->first->sibling; # skip pushmark
1951 for (; !null($kid->sibling); $kid = $kid->sibling) {
1952 push @exprs, $self->deparse($kid, 6);
1955 $left = "(" . join(", ", @exprs). ")";
1957 $left = $self->deparse_binop_left($op, $left, $prec);
1959 $right = $self->deparse_binop_right($op, $right, $prec);
1960 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1965 my ($op, $cx, $type) = @_;
1966 my $left = $op->first;
1967 my $right = $left->sibling;
1968 $left = $self->deparse($left, 9);
1969 $right = $self->deparse($right, 9);
1970 return $self->maybe_parens("$left $type $right", $cx, 9);
1976 my $flip = $op->first;
1977 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1978 return $self->range($flip->first, $cx, $type);
1981 # one-line while/until is handled in pp_leave
1985 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1986 my $left = $op->first;
1987 my $right = $op->first->sibling;
1988 if ($cx == 0 and is_scope($right) and $blockname
1989 and $self->{'expand'} < 7)
1991 $left = $self->deparse($left, 1);
1992 $right = $self->deparse($right, 0);
1993 return "$blockname ($left) {\n\t$right\n\b}\cK";
1994 } elsif ($cx == 0 and $blockname and not $self->{'parens'}
1995 and $self->{'expand'} < 7) { # $b if $a
1996 $right = $self->deparse($right, 1);
1997 $left = $self->deparse($left, 1);
1998 return "$right $blockname $left";
1999 } elsif ($cx > $lowprec and $highop) { # $a && $b
2000 $left = $self->deparse_binop_left($op, $left, $highprec);
2001 $right = $self->deparse_binop_right($op, $right, $highprec);
2002 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
2003 } else { # $a and $b
2004 $left = $self->deparse_binop_left($op, $left, $lowprec);
2005 $right = $self->deparse_binop_right($op, $right, $lowprec);
2006 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
2010 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
2011 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
2013 # xor is syntactically a logop, but it's really a binop (contrary to
2014 # old versions of opcode.pl). Syntax is what matters here.
2015 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
2019 my ($op, $cx, $opname) = @_;
2020 my $left = $op->first;
2021 my $right = $op->first->sibling->first; # skip sassign
2022 $left = $self->deparse($left, 7);
2023 $right = $self->deparse($right, 7);
2024 return $self->maybe_parens("$left $opname $right", $cx, 7);
2027 sub pp_andassign { logassignop(@_, "&&=") }
2028 sub pp_orassign { logassignop(@_, "||=") }
2032 my($op, $cx, $name) = @_;
2034 my $parens = ($cx >= 5) || $self->{'parens'};
2035 my $kid = $op->first->sibling;
2036 return $name if null $kid;
2038 if (defined prototype("CORE::$name")
2039 && prototype("CORE::$name") =~ /^;?\*/
2040 && $kid->name eq "rv2gv") {
2041 $first = $self->deparse($kid->first, 6);
2044 $first = $self->deparse($kid, 6);
2046 if ($name eq "chmod" && $first =~ /^\d+$/) {
2047 $first = sprintf("%#o", $first);
2049 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
2050 push @exprs, $first;
2051 $kid = $kid->sibling;
2052 for (; !null($kid); $kid = $kid->sibling) {
2053 push @exprs, $self->deparse($kid, 6);
2056 return "$name(" . join(", ", @exprs) . ")";
2058 return "$name " . join(", ", @exprs);
2062 sub pp_bless { listop(@_, "bless") }
2063 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
2064 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
2065 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
2066 sub pp_index { maybe_targmy(@_, \&listop, "index") }
2067 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
2068 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
2069 sub pp_formline { listop(@_, "formline") } # see also deparse_format
2070 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
2071 sub pp_unpack { listop(@_, "unpack") }
2072 sub pp_pack { listop(@_, "pack") }
2073 sub pp_join { maybe_targmy(@_, \&listop, "join") }
2074 sub pp_splice { listop(@_, "splice") }
2075 sub pp_push { maybe_targmy(@_, \&listop, "push") }
2076 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
2077 sub pp_reverse { listop(@_, "reverse") }
2078 sub pp_warn { listop(@_, "warn") }
2079 sub pp_die { listop(@_, "die") }
2080 # Actually, return is exempt from the LLAFR (see examples in this very
2081 # module!), but for consistency's sake, ignore that fact
2082 sub pp_return { listop(@_, "return") }
2083 sub pp_open { listop(@_, "open") }
2084 sub pp_pipe_op { listop(@_, "pipe") }
2085 sub pp_tie { listop(@_, "tie") }
2086 sub pp_binmode { listop(@_, "binmode") }
2087 sub pp_dbmopen { listop(@_, "dbmopen") }
2088 sub pp_sselect { listop(@_, "select") }
2089 sub pp_select { listop(@_, "select") }
2090 sub pp_read { listop(@_, "read") }
2091 sub pp_sysopen { listop(@_, "sysopen") }
2092 sub pp_sysseek { listop(@_, "sysseek") }
2093 sub pp_sysread { listop(@_, "sysread") }
2094 sub pp_syswrite { listop(@_, "syswrite") }
2095 sub pp_send { listop(@_, "send") }
2096 sub pp_recv { listop(@_, "recv") }
2097 sub pp_seek { listop(@_, "seek") }
2098 sub pp_fcntl { listop(@_, "fcntl") }
2099 sub pp_ioctl { listop(@_, "ioctl") }
2100 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
2101 sub pp_socket { listop(@_, "socket") }
2102 sub pp_sockpair { listop(@_, "sockpair") }
2103 sub pp_bind { listop(@_, "bind") }
2104 sub pp_connect { listop(@_, "connect") }
2105 sub pp_listen { listop(@_, "listen") }
2106 sub pp_accept { listop(@_, "accept") }
2107 sub pp_shutdown { listop(@_, "shutdown") }
2108 sub pp_gsockopt { listop(@_, "getsockopt") }
2109 sub pp_ssockopt { listop(@_, "setsockopt") }
2110 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
2111 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
2112 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
2113 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
2114 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
2115 sub pp_link { maybe_targmy(@_, \&listop, "link") }
2116 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
2117 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
2118 sub pp_open_dir { listop(@_, "opendir") }
2119 sub pp_seekdir { listop(@_, "seekdir") }
2120 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
2121 sub pp_system { maybe_targmy(@_, \&listop, "system") }
2122 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
2123 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
2124 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
2125 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
2126 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
2127 sub pp_shmget { listop(@_, "shmget") }
2128 sub pp_shmctl { listop(@_, "shmctl") }
2129 sub pp_shmread { listop(@_, "shmread") }
2130 sub pp_shmwrite { listop(@_, "shmwrite") }
2131 sub pp_msgget { listop(@_, "msgget") }
2132 sub pp_msgctl { listop(@_, "msgctl") }
2133 sub pp_msgsnd { listop(@_, "msgsnd") }
2134 sub pp_msgrcv { listop(@_, "msgrcv") }
2135 sub pp_semget { listop(@_, "semget") }
2136 sub pp_semctl { listop(@_, "semctl") }
2137 sub pp_semop { listop(@_, "semop") }
2138 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
2139 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
2140 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
2141 sub pp_gsbyname { listop(@_, "getservbyname") }
2142 sub pp_gsbyport { listop(@_, "getservbyport") }
2143 sub pp_syscall { listop(@_, "syscall") }
2148 my $text = $self->dq($op->first->sibling); # skip pushmark
2149 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
2150 or $text =~ /[<>]/) {
2151 return 'glob(' . single_delim('qq', '"', $text) . ')';
2153 return '<' . $text . '>';
2157 # Truncate is special because OPf_SPECIAL makes a bareword first arg
2158 # be a filehandle. This could probably be better fixed in the core
2159 # by moving the GV lookup into ck_truc.
2165 my $parens = ($cx >= 5) || $self->{'parens'};
2166 my $kid = $op->first->sibling;
2168 if ($op->flags & OPf_SPECIAL) {
2169 # $kid is an OP_CONST
2170 $fh = $self->const_sv($kid)->PV;
2172 $fh = $self->deparse($kid, 6);
2173 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
2175 my $len = $self->deparse($kid->sibling, 6);
2177 return "truncate($fh, $len)";
2179 return "truncate $fh, $len";
2185 my($op, $cx, $name) = @_;
2187 my $kid = $op->first->sibling;
2189 if ($op->flags & OPf_STACKED) {
2191 $indir = $indir->first; # skip rv2gv
2192 if (is_scope($indir)) {
2193 $indir = "{" . $self->deparse($indir, 0) . "}";
2194 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
2195 $indir = $self->const_sv($indir)->PV;
2197 $indir = $self->deparse($indir, 24);
2199 $indir = $indir . " ";
2200 $kid = $kid->sibling;
2202 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
2203 $indir = ($op->private & OPpSORT_REVERSE) ? '{$b <=> $a} '
2206 elsif ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
2207 $indir = '{$b cmp $a} ';
2209 for (; !null($kid); $kid = $kid->sibling) {
2210 $expr = $self->deparse($kid, 6);
2213 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
2217 sub pp_prtf { indirop(@_, "printf") }
2218 sub pp_print { indirop(@_, "print") }
2219 sub pp_sort { indirop(@_, "sort") }
2223 my($op, $cx, $name) = @_;
2225 my $kid = $op->first; # this is the (map|grep)start
2226 $kid = $kid->first->sibling; # skip a pushmark
2227 my $code = $kid->first; # skip a null
2228 if (is_scope $code) {
2229 $code = "{" . $self->deparse($code, 0) . "} ";
2231 $code = $self->deparse($code, 24) . ", ";
2233 $kid = $kid->sibling;
2234 for (; !null($kid); $kid = $kid->sibling) {
2235 $expr = $self->deparse($kid, 6);
2236 push @exprs, $expr if $expr;
2238 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2241 sub pp_mapwhile { mapop(@_, "map") }
2242 sub pp_grepwhile { mapop(@_, "grep") }
2248 my $kid = $op->first->sibling; # skip pushmark
2250 my $local = "either"; # could be local(...), my(...) or our(...)
2251 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2252 # This assumes that no other private flags equal 128, and that
2253 # OPs that store things other than flags in their op_private,
2254 # like OP_AELEMFAST, won't be immediate children of a list.
2256 # OP_ENTERSUB can break this logic, so check for it.
2257 # I suspect that open and exit can too.
2259 if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
2260 or $lop->name eq "undef")
2261 or $lop->name eq "entersub"
2262 or $lop->name eq "exit"
2263 or $lop->name eq "open")
2265 $local = ""; # or not
2268 if ($lop->name =~ /^pad[ash]v$/) { # my()
2269 ($local = "", last) if $local eq "local" || $local eq "our";
2271 } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
2272 && $lop->private & OPpOUR_INTRO
2273 or $lop->name eq "null" && $lop->first->name eq "gvsv"
2274 && $lop->first->private & OPpOUR_INTRO) { # our()
2275 ($local = "", last) if $local eq "my" || $local eq "local";
2277 } elsif ($lop->name ne "undef") { # local()
2278 ($local = "", last) if $local eq "my" || $local eq "our";
2282 $local = "" if $local eq "either"; # no point if it's all undefs
2283 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2284 for (; !null($kid); $kid = $kid->sibling) {
2286 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2291 $self->{'avoid_local'}{$$lop}++;
2292 $expr = $self->deparse($kid, 6);
2293 delete $self->{'avoid_local'}{$$lop};
2295 $expr = $self->deparse($kid, 6);
2300 return "$local(" . join(", ", @exprs) . ")";
2302 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2306 sub is_ifelse_cont {
2308 return ($op->name eq "null" and class($op) eq "UNOP"
2309 and $op->first->name =~ /^(and|cond_expr)$/
2310 and is_scope($op->first->first->sibling));
2316 my $cond = $op->first;
2317 my $true = $cond->sibling;
2318 my $false = $true->sibling;
2319 my $cuddle = $self->{'cuddle'};
2320 unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
2321 (is_scope($false) || is_ifelse_cont($false))
2322 and $self->{'expand'} < 7) {
2323 $cond = $self->deparse($cond, 8);
2324 $true = $self->deparse($true, 8);
2325 $false = $self->deparse($false, 8);
2326 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2329 $cond = $self->deparse($cond, 1);
2330 $true = $self->deparse($true, 0);
2331 my $head = "if ($cond) {\n\t$true\n\b}";
2333 while (!null($false) and is_ifelse_cont($false)) {
2334 my $newop = $false->first;
2335 my $newcond = $newop->first;
2336 my $newtrue = $newcond->sibling;
2337 $false = $newtrue->sibling; # last in chain is OP_AND => no else
2338 $newcond = $self->deparse($newcond, 1);
2339 $newtrue = $self->deparse($newtrue, 0);
2340 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2342 if (!null($false)) {
2343 $false = $cuddle . "else {\n\t" .
2344 $self->deparse($false, 0) . "\n\b}\cK";
2348 return $head . join($cuddle, "", @elsifs) . $false;
2353 my($op, $cx, $init) = @_;
2354 my $enter = $op->first;
2355 my $kid = $enter->sibling;
2356 local(@$self{qw'curstash warnings hints'})
2357 = @$self{qw'curstash warnings hints'};
2362 if ($kid->name eq "lineseq") { # bare or infinite loop
2363 if (is_state $kid->last) { # infinite
2364 $head = "while (1) "; # Can't use for(;;) if there's a continue
2370 } elsif ($enter->name eq "enteriter") { # foreach
2371 my $ary = $enter->first->sibling; # first was pushmark
2372 my $var = $ary->sibling;
2373 if ($enter->flags & OPf_STACKED
2374 and not null $ary->first->sibling->sibling)
2376 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2377 $self->deparse($ary->first->sibling->sibling, 9);
2379 $ary = $self->deparse($ary, 1);
2382 if ($enter->flags & OPf_SPECIAL) { # thread special var
2383 $var = $self->pp_threadsv($enter, 1);
2384 } else { # regular my() variable
2385 $var = $self->pp_padsv($enter, 1);
2386 if ($self->padname_sv($enter->targ)->IVX ==
2387 $kid->first->first->sibling->last->cop_seq)
2389 # If the scope of this variable closes at the last
2390 # statement of the loop, it must have been
2392 $var = "my " . $var;
2395 } elsif ($var->name eq "rv2gv") {
2396 $var = $self->pp_rv2sv($var, 1);
2397 } elsif ($var->name eq "gv") {
2398 $var = "\$" . $self->deparse($var, 1);
2400 $head = "foreach $var ($ary) ";
2401 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2402 } elsif ($kid->name eq "null") { # while/until
2404 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2405 $cond = $self->deparse($kid->first, 1);
2406 $head = "$name ($cond) ";
2407 $body = $kid->first->sibling;
2408 } elsif ($kid->name eq "stub") { # bare and empty
2409 return "{;}"; # {} could be a hashref
2411 # If there isn't a continue block, then the next pointer for the loop
2412 # will point to the unstack, which is kid's penultimate child, except
2413 # in a bare loop, when it will point to the leaveloop. When neither of
2414 # these conditions hold, then the third-to-last child in the continue
2415 # block (or the last in a bare loop).
2416 my $cont_start = $enter->nextop;
2418 if ($$cont_start != $$op && ${$cont_start->sibling} != ${$body->last}) {
2420 $cont = $body->last;
2422 $cont = $body->first;
2423 while (!null($cont->sibling->sibling->sibling)) {
2424 $cont = $cont->sibling;
2427 my $state = $body->first;
2428 my $cuddle = $self->{'cuddle'};
2430 for (; $$state != $$cont; $state = $state->sibling) {
2431 push @states, $state;
2433 $body = $self->lineseq(undef, @states);
2434 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2435 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2438 $cont = $cuddle . "continue {\n\t" .
2439 $self->deparse($cont, 0) . "\n\b}\cK";
2442 return "" if !defined $body;
2444 $head = "for ($init; $cond;) ";
2447 $body = $self->deparse($body, 0);
2449 $body =~ s/;?$/;\n/;
2451 return $head . "{\n\t" . $body . "\b}" . $cont;
2454 sub pp_leaveloop { loop_common(@_, "") }
2459 my $init = $self->deparse($op, 1);
2460 return $self->loop_common($op->sibling->first->sibling, $cx, $init);
2465 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2468 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2469 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2470 BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
2471 BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
2476 if (class($op) eq "OP") {
2478 return $self->{'ex_const'} if $op->targ == OP_CONST;
2479 } elsif ($op->first->name eq "pushmark") {
2480 return $self->pp_list($op, $cx);
2481 } elsif ($op->first->name eq "enter") {
2482 return $self->pp_leave($op, $cx);
2483 } elsif ($op->targ == OP_STRINGIFY) {
2484 return $self->dquote($op, $cx);
2485 } elsif (!null($op->first->sibling) and
2486 $op->first->sibling->name eq "readline" and
2487 $op->first->sibling->flags & OPf_STACKED) {
2488 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2489 . $self->deparse($op->first->sibling, 7),
2491 } elsif (!null($op->first->sibling) and
2492 $op->first->sibling->name eq "trans" and
2493 $op->first->sibling->flags & OPf_STACKED) {
2494 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2495 . $self->deparse($op->first->sibling, 20),
2497 } elsif ($op->flags & OPf_SPECIAL && $cx == 0 && !$op->targ) {
2498 return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
2499 } elsif (!null($op->first->sibling) and
2500 $op->first->sibling->name eq "null" and
2501 class($op->first->sibling) eq "UNOP" and
2502 $op->first->sibling->first->flags & OPf_STACKED and
2503 $op->first->sibling->first->name eq "rcatline") {
2504 return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
2505 . $self->deparse($op->first->sibling, 18),
2508 return $self->deparse($op->first, $cx);
2515 return $self->padname_sv($targ)->PVX;
2521 return substr($self->padname($op->targ), 1); # skip $/@/%
2527 return $self->maybe_my($op, $cx, $self->padname($op->targ));
2530 sub pp_padav { pp_padsv(@_) }
2531 sub pp_padhv { pp_padsv(@_) }
2536 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2537 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2538 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2545 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
2551 if (class($op) eq "PADOP") {
2552 return $self->padval($op->padix);
2553 } else { # class($op) eq "SVOP"
2561 my $gv = $self->gv_or_padgv($op);
2562 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2563 $self->gv_name($gv)));
2569 my $gv = $self->gv_or_padgv($op);
2570 return $self->gv_name($gv);
2576 my $gv = $self->gv_or_padgv($op);
2577 my $name = $self->gv_name($gv);
2578 $name = $self->{'curstash'}."::$name"
2579 if $name !~ /::/ && $self->lex_in_scope('@'.$name);
2581 return "\$" . $name . "[" .
2582 ($op->private + $self->{'arybase'}) . "]";
2587 my($op, $cx, $type) = @_;
2589 if (class($op) eq 'NULL' || !$op->can("first")) {
2590 Carp::cluck("Unexpected op in pp_rv2x");
2593 my $kid = $op->first;
2594 my $str = $self->deparse($kid, 0);
2595 return $self->stash_variable($type, $str) if is_scalar($kid);
2596 return $type ."{$str}";
2599 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2600 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2601 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2607 if ($op->first->name eq "padav") {
2608 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2610 return $self->maybe_local($op, $cx,
2611 $self->rv2x($op->first, $cx, '$#'));
2615 # skip down to the old, ex-rv2cv
2617 my ($self, $op, $cx) = @_;
2618 if (!null($op->first) && $op->first->name eq 'null' &&
2619 $op->first->targ eq OP_LIST)
2621 return $self->rv2x($op->first->first->sibling, $cx, "&")
2624 return $self->rv2x($op, $cx, "")
2631 my $kid = $op->first;
2632 if ($kid->name eq "const") { # constant list
2633 my $av = $self->const_sv($kid);
2634 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2636 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2640 sub is_subscriptable {
2642 if ($op->name =~ /^[ahg]elem/) {
2644 } elsif ($op->name eq "entersub") {
2645 my $kid = $op->first;
2646 return 0 unless null $kid->sibling;
2648 $kid = $kid->sibling until null $kid->sibling;
2649 return 0 if is_scope($kid);
2651 return 0 if $kid->name eq "gv";
2652 return 0 if is_scalar($kid);
2653 return is_subscriptable($kid);
2661 my ($op, $cx, $left, $right, $padname) = @_;
2662 my($array, $idx) = ($op->first, $op->first->sibling);
2663 unless ($array->name eq $padname) { # Maybe this has been fixed
2664 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2666 if ($array->name eq $padname) {
2667 $array = $self->padany($array);
2668 } elsif (is_scope($array)) { # ${expr}[0]
2669 $array = "{" . $self->deparse($array, 0) . "}";
2670 } elsif ($array->name eq "gv") {
2671 $array = $self->gv_name($self->gv_or_padgv($array));
2672 if ($array !~ /::/) {
2673 my $prefix = ($left eq '[' ? '@' : '%');
2674 $array = $self->{curstash}.'::'.$array
2675 if $self->lex_in_scope($prefix . $array);
2677 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2678 $array = $self->deparse($array, 24);
2680 # $x[20][3]{hi} or expr->[20]
2681 my $arrow = is_subscriptable($array) ? "" : "->";
2682 return $self->deparse($array, 24) . $arrow .
2683 $left . $self->deparse($idx, 1) . $right;
2685 $idx = $self->deparse($idx, 1);
2687 # Outer parens in an array index will confuse perl
2688 # if we're interpolating in a regular expression, i.e.
2689 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2691 # If $self->{parens}, then an initial '(' will
2692 # definitely be paired with a final ')'. If
2693 # !$self->{parens}, the misleading parens won't
2694 # have been added in the first place.
2696 # [You might think that we could get "(...)...(...)"
2697 # where the initial and final parens do not match
2698 # each other. But we can't, because the above would
2699 # only happen if there's an infix binop between the
2700 # two pairs of parens, and *that* means that the whole
2701 # expression would be parenthesized as well.]
2703 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2705 # Hash-element braces will autoquote a bareword inside themselves.
2706 # We need to make sure that C<$hash{warn()}> doesn't come out as
2707 # C<$hash{warn}>, which has a quite different meaning. Currently
2708 # B::Deparse will always quote strings, even if the string was a
2709 # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
2710 # for constant strings.) So we can cheat slightly here - if we see
2711 # a bareword, we know that it is supposed to be a function call.
2713 $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
2715 return "\$" . $array . $left . $idx . $right;
2718 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2719 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2724 my($glob, $part) = ($op->first, $op->last);
2725 $glob = $glob->first; # skip rv2gv
2726 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2727 my $scope = is_scope($glob);
2728 $glob = $self->deparse($glob, 0);
2729 $part = $self->deparse($part, 1);
2730 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2735 my ($op, $cx, $left, $right, $regname, $padname) = @_;
2737 my(@elems, $kid, $array, $list);
2738 if (class($op) eq "LISTOP") {
2740 } else { # ex-hslice inside delete()
2741 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2745 $array = $array->first
2746 if $array->name eq $regname or $array->name eq "null";
2747 if (is_scope($array)) {
2748 $array = "{" . $self->deparse($array, 0) . "}";
2749 } elsif ($array->name eq $padname) {
2750 $array = $self->padany($array);
2752 $array = $self->deparse($array, 24);
2754 $kid = $op->first->sibling; # skip pushmark
2755 if ($kid->name eq "list") {
2756 $kid = $kid->first->sibling; # skip list, pushmark
2757 for (; !null $kid; $kid = $kid->sibling) {
2758 push @elems, $self->deparse($kid, 6);
2760 $list = join(", ", @elems);
2762 $list = $self->deparse($kid, 1);
2764 return "\@" . $array . $left . $list . $right;
2767 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2768 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2773 my $idx = $op->first;
2774 my $list = $op->last;
2776 $list = $self->deparse($list, 1);
2777 $idx = $self->deparse($idx, 1);
2778 return "($list)" . "[$idx]";
2783 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2788 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2794 my $kid = $op->first->sibling; # skip pushmark
2795 my($meth, $obj, @exprs);
2796 if ($kid->name eq "list" and want_list $kid) {
2797 # When an indirect object isn't a bareword but the args are in
2798 # parens, the parens aren't part of the method syntax (the LLAFR
2799 # doesn't apply), but they make a list with OPf_PARENS set that
2800 # doesn't get flattened by the append_elem that adds the method,
2801 # making a (object, arg1, arg2, ...) list where the object
2802 # usually is. This can be distinguished from
2803 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2804 # object) because in the later the list is in scalar context
2805 # as the left side of -> always is, while in the former
2806 # the list is in list context as method arguments always are.
2807 # (Good thing there aren't method prototypes!)
2808 $meth = $kid->sibling;
2809 $kid = $kid->first->sibling; # skip pushmark
2811 $kid = $kid->sibling;
2812 for (; not null $kid; $kid = $kid->sibling) {
2813 push @exprs, $self->deparse($kid, 6);
2817 $kid = $kid->sibling;
2818 for (; !null ($kid->sibling) && $kid->name ne "method_named";
2819 $kid = $kid->sibling) {
2820 push @exprs, $self->deparse($kid, 6);
2824 $obj = $self->deparse($obj, 24);
2825 if ($meth->name eq "method_named") {
2826 $meth = $self->const_sv($meth)->PV;
2828 $meth = $meth->first;
2829 if ($meth->name eq "const") {
2830 # As of 5.005_58, this case is probably obsoleted by the
2831 # method_named case above
2832 $meth = $self->const_sv($meth)->PV; # needs to be bare
2834 $meth = $self->deparse($meth, 1);
2837 my $args = join(", ", @exprs);
2838 $kid = $obj . "->" . $meth;
2840 return $kid . "(" . $args . ")"; # parens mandatory
2846 # returns "&" if the prototype doesn't match the args,
2847 # or ("", $args_after_prototype_demunging) if it does.
2850 my($proto, @args) = @_;
2854 # An unbackslashed @ or % gobbles up the rest of the args
2855 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2857 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2860 return "&" if @args;
2861 } elsif ($chr eq ";") {
2863 } elsif ($chr eq "@" or $chr eq "%") {
2864 push @reals, map($self->deparse($_, 6), @args);
2870 if (want_scalar $arg) {
2871 push @reals, $self->deparse($arg, 6);
2875 } elsif ($chr eq "&") {
2876 if ($arg->name =~ /^(s?refgen|undef)$/) {
2877 push @reals, $self->deparse($arg, 6);
2881 } elsif ($chr eq "*") {
2882 if ($arg->name =~ /^s?refgen$/
2883 and $arg->first->first->name eq "rv2gv")
2885 $real = $arg->first->first; # skip refgen, null
2886 if ($real->first->name eq "gv") {
2887 push @reals, $self->deparse($real, 6);
2889 push @reals, $self->deparse($real->first, 6);
2894 } elsif (substr($chr, 0, 1) eq "\\") {
2895 $chr = substr($chr, 1);
2896 if ($arg->name =~ /^s?refgen$/ and
2897 !null($real = $arg->first) and
2898 ($chr eq "\$" && is_scalar($real->first)
2900 && $real->first->sibling->name
2903 && $real->first->sibling->name
2905 #or ($chr eq "&" # This doesn't work
2906 # && $real->first->name eq "rv2cv")
2908 && $real->first->name eq "rv2gv")))
2910 push @reals, $self->deparse($real, 6);
2917 return "&" if $proto and !$doneok; # too few args and no `;'
2918 return "&" if @args; # too many args
2919 return ("", join ", ", @reals);
2925 return $self->method($op, $cx) unless null $op->first->sibling;
2929 if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
2931 } elsif ($op->private & OPpENTERSUB_AMPER) {
2935 $kid = $kid->first->sibling; # skip ex-list, pushmark
2936 for (; not null $kid->sibling; $kid = $kid->sibling) {
2941 if (is_scope($kid)) {
2943 $kid = "{" . $self->deparse($kid, 0) . "}";
2944 } elsif ($kid->first->name eq "gv") {
2945 my $gv = $self->gv_or_padgv($kid->first);
2946 if (class($gv->CV) ne "SPECIAL") {
2947 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2949 $simple = 1; # only calls of named functions can be prototyped
2950 $kid = $self->deparse($kid, 24);
2951 } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
2953 $kid = $self->deparse($kid, 24);
2956 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2957 $kid = $self->deparse($kid, 24) . $arrow;
2960 # Doesn't matter how many prototypes there are, if
2961 # they haven't happened yet!
2962 my $declared = exists $self->{'subs_declared'}{$kid};
2963 if (!$declared && defined($proto)) {
2964 # Avoid "too early to check prototype" warning
2965 ($amper, $proto) = ('&');
2969 if ($declared and defined $proto and not $amper) {
2970 ($amper, $args) = $self->check_proto($proto, @exprs);
2971 if ($amper eq "&") {
2972 $args = join(", ", map($self->deparse($_, 6), @exprs));
2975 $args = join(", ", map($self->deparse($_, 6), @exprs));
2977 if ($prefix or $amper) {
2978 if ($op->flags & OPf_STACKED) {
2979 return $prefix . $amper . $kid . "(" . $args . ")";
2981 return $prefix . $amper. $kid;
2984 # glob() invocations can be translated into calls of
2985 # CORE::GLOBAL::glob with a second parameter, a number.
2987 if ($kid eq "CORE::GLOBAL::glob") {
2989 $args =~ s/\s*,[^,]+$//;
2992 # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
2993 # so it must have been translated from a keyword call. Translate
2995 $kid =~ s/^CORE::GLOBAL:://;
2998 return "$kid(" . $args . ")";
2999 } elsif (defined $proto and $proto eq "") {
3001 } elsif (defined $proto and $proto eq "\$" and is_scalar($exprs[0])) {
3002 return $self->maybe_parens_func($kid, $args, $cx, 16);
3003 } elsif (defined($proto) && $proto or $simple) {
3004 return $self->maybe_parens_func($kid, $args, $cx, 5);
3006 return "$kid(" . $args . ")";
3011 sub pp_enterwrite { unop(@_, "write") }
3013 # escape things that cause interpolation in double quotes,
3014 # but not character escapes
3017 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
3025 # Matches any string which is balanced with respect to {braces}
3036 # the same, but treat $|, $), $( and $ at the end of the string differently
3050 (\(\?\??\{$bal\}\)) # $4
3056 /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3061 # This is for regular expressions with the /x modifier
3062 # We have to leave comments unmangled.
3063 sub re_uninterp_extended {
3076 ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
3077 | \#[^\n]* # (skip over comments)
3084 /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3090 # character escapes, but not delimiters that might need to be escaped
3091 sub escape_str { # ASCII, UTF8
3093 $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3095 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
3101 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
3102 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
3106 # For regexes with the /x modifier.
3107 # Leave whitespace unmangled.
3108 sub escape_extended_re {
3110 $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3111 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
3112 $str =~ s/\n/\n\f/g;
3116 # Don't do this for regexen
3119 $str =~ s/\\/\\\\/g;
3123 # Remove backslashes which precede literal control characters,
3124 # to avoid creating ambiguity when we escape the latter.
3128 # the insane complexity here is due to the behaviour of "\c\"
3129 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
3133 sub balanced_delim {
3135 my @str = split //, $str;
3136 my($ar, $open, $close, $fail, $c, $cnt);
3137 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
3138 ($open, $close) = @$ar;
3139 $fail = 0; $cnt = 0;
3143 } elsif ($c eq $close) {
3152 $fail = 1 if $cnt != 0;
3153 return ($open, "$open$str$close") if not $fail;
3159 my($q, $default, $str) = @_;
3160 return "$default$str$default" if $default and index($str, $default) == -1;
3161 my($succeed, $delim);
3162 ($succeed, $str) = balanced_delim($str);
3163 return "$q$str" if $succeed;
3164 for $delim ('/', '"', '#') {
3165 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3168 $str =~ s/$default/\\$default/g;
3169 return "$default$str$default";
3178 if (class($sv) eq "SPECIAL") {
3179 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
3180 } elsif (class($sv) eq "NULL") {
3182 } elsif ($sv->FLAGS & SVf_IOK) {
3183 return $sv->int_value;
3184 } elsif ($sv->FLAGS & SVf_NOK) {
3185 # try the default stringification
3188 # If it's in scientific notation, we might have lost information
3189 return sprintf("%.20e", $sv->NV);
3192 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3193 return "\\(" . const($sv->RV) . ")"; # constant folded
3194 } elsif ($sv->FLAGS & SVf_POK) {
3196 if ($str =~ /[^ -~]/) { # ASCII for non-printing
3197 return single_delim("qq", '"', uninterp escape_str unback $str);
3199 return single_delim("q", "'", unback $str);
3210 # the constant could be in the pad (under useithreads)
3211 $sv = $self->padval($op->targ) unless $$sv;
3218 if ($op->private & OPpCONST_ARYBASE) {
3221 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3222 # return $self->const_sv($op)->PV;
3224 my $sv = $self->const_sv($op);
3225 # return const($sv);
3227 return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
3233 my $type = $op->name;
3234 if ($type eq "const") {
3235 return '$[' if $op->private & OPpCONST_ARYBASE;
3236 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3237 } elsif ($type eq "concat") {
3238 my $first = $self->dq($op->first);
3239 my $last = $self->dq($op->last);
3241 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3242 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3243 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
3244 || ($last =~ /^[{\[\w_]/ &&
3245 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3247 return $first . $last;
3248 } elsif ($type eq "uc") {
3249 return '\U' . $self->dq($op->first->sibling) . '\E';
3250 } elsif ($type eq "lc") {
3251 return '\L' . $self->dq($op->first->sibling) . '\E';
3252 } elsif ($type eq "ucfirst") {
3253 return '\u' . $self->dq($op->first->sibling);
3254 } elsif ($type eq "lcfirst") {
3255 return '\l' . $self->dq($op->first->sibling);
3256 } elsif ($type eq "quotemeta") {
3257 return '\Q' . $self->dq($op->first->sibling) . '\E';
3258 } elsif ($type eq "join") {
3259 return $self->deparse($op->last, 26); # was join($", @ary)
3261 return $self->deparse($op, 26);
3269 return single_delim("qx", '`', $self->dq($op->first->sibling));
3275 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3276 return $self->deparse($kid, $cx) if $self->{'unquote'};
3277 $self->maybe_targmy($kid, $cx,
3278 sub {single_delim("qq", '"', $self->dq($_[1]))});
3281 # OP_STRINGIFY is a listop, but it only ever has one arg
3282 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3284 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3285 # note that tr(from)/to/ is OK, but not tr/from/(to)
3287 my($from, $to) = @_;
3288 my($succeed, $delim);
3289 if ($from !~ m[/] and $to !~ m[/]) {
3290 return "/$from/$to/";
3291 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3292 if (($succeed, $to) = balanced_delim($to) and $succeed) {
3295 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3296 return "$from$delim$to$delim" if index($to, $delim) == -1;
3299 return "$from/$to/";
3302 for $delim ('/', '"', '#') { # note no '
3303 return "$delim$from$delim$to$delim"
3304 if index($to . $from, $delim) == -1;
3306 $from =~ s[/][\\/]g;
3308 return "/$from/$to/";
3312 # Only used by tr///, so backslashes hyphens
3315 if ($n == ord '\\') {
3317 } elsif ($n == ord "-") {
3319 } elsif ($n >= ord(' ') and $n <= ord('~')) {
3321 } elsif ($n == ord "\a") {
3323 } elsif ($n == ord "\b") {
3325 } elsif ($n == ord "\t") {
3327 } elsif ($n == ord "\n") {
3329 } elsif ($n == ord "\e") {
3331 } elsif ($n == ord "\f") {
3333 } elsif ($n == ord "\r") {
3335 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3336 return '\\c' . chr(ord("@") + $n);
3338 # return '\x' . sprintf("%02x", $n);
3339 return '\\' . sprintf("%03o", $n);
3345 my($str, $c, $tr) = ("");
3346 for ($c = 0; $c < @chars; $c++) {
3349 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3350 $chars[$c + 2] == $tr + 2)
3352 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3355 $str .= pchr($chars[$c]);
3361 sub tr_decode_byte {
3362 my($table, $flags) = @_;
3363 my(@table) = unpack("s*", $table);
3364 splice @table, 0x100, 1; # Number of subsequent elements
3365 my($c, $tr, @from, @to, @delfrom, $delhyphen);
3366 if ($table[ord "-"] != -1 and
3367 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3369 $tr = $table[ord "-"];
3370 $table[ord "-"] = -1;
3374 } else { # -2 ==> delete
3378 for ($c = 0; $c < @table; $c++) {
3381 push @from, $c; push @to, $tr;
3382 } elsif ($tr == -2) {
3386 @from = (@from, @delfrom);
3387 if ($flags & OPpTRANS_COMPLEMENT) {
3390 @from{@from} = (1) x @from;
3391 for ($c = 0; $c < 256; $c++) {
3392 push @newfrom, $c unless $from{$c};
3396 unless ($flags & OPpTRANS_DELETE || !@to) {
3397 pop @to while $#to and $to[$#to] == $to[$#to -1];
3400 $from = collapse(@from);
3401 $to = collapse(@to);
3402 $from .= "-" if $delhyphen;
3403 return ($from, $to);
3408 if ($x == ord "-") {
3410 } elsif ($x == ord "\\") {
3417 # XXX This doesn't yet handle all cases correctly either
3419 sub tr_decode_utf8 {
3420 my($swash_hv, $flags) = @_;
3421 my %swash = $swash_hv->ARRAY;
3423 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3424 my $none = $swash{"NONE"}->IV;
3425 my $extra = $none + 1;
3426 my(@from, @delfrom, @to);
3428 foreach $line (split /\n/, $swash{'LIST'}->PV) {
3429 my($min, $max, $result) = split(/\t/, $line);
3436 $result = hex $result;
3437 if ($result == $extra) {
3438 push @delfrom, [$min, $max];
3440 push @from, [$min, $max];
3441 push @to, [$result, $result + $max - $min];
3444 for my $i (0 .. $#from) {
3445 if ($from[$i][0] == ord '-') {
3446 unshift @from, splice(@from, $i, 1);
3447 unshift @to, splice(@to, $i, 1);
3449 } elsif ($from[$i][1] == ord '-') {
3452 unshift @from, ord '-';
3453 unshift @to, ord '-';
3457 for my $i (0 .. $#delfrom) {
3458 if ($delfrom[$i][0] == ord '-') {
3459 push @delfrom, splice(@delfrom, $i, 1);
3461 } elsif ($delfrom[$i][1] == ord '-') {
3463 push @delfrom, ord '-';
3467 if (defined $final and $to[$#to][1] != $final) {
3468 push @to, [$final, $final];
3470 push @from, @delfrom;
3471 if ($flags & OPpTRANS_COMPLEMENT) {
3474 for my $i (0 .. $#from) {
3475 push @newfrom, [$next, $from[$i][0] - 1];
3476 $next = $from[$i][1] + 1;
3479 for my $range (@newfrom) {
3480 if ($range->[0] <= $range->[1]) {
3485 my($from, $to, $diff);
3486 for my $chunk (@from) {
3487 $diff = $chunk->[1] - $chunk->[0];
3489 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3490 } elsif ($diff == 1) {
3491 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3493 $from .= tr_chr($chunk->[0]);
3496 for my $chunk (@to) {
3497 $diff = $chunk->[1] - $chunk->[0];
3499 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3500 } elsif ($diff == 1) {
3501 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3503 $to .= tr_chr($chunk->[0]);
3506 #$final = sprintf("%04x", $final) if defined $final;
3507 #$none = sprintf("%04x", $none) if defined $none;
3508 #$extra = sprintf("%04x", $extra) if defined $extra;
3509 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3510 #print STDERR $swash{'LIST'}->PV;
3511 return (escape_str($from), escape_str($to));
3518 if (class($op) eq "PVOP") {
3519 ($from, $to) = tr_decode_byte($op->pv, $op->private);
3520 } else { # class($op) eq "SVOP"
3521 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3524 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3525 $flags .= "d" if $op->private & OPpTRANS_DELETE;
3526 $to = "" if $from eq $to and $flags eq "";
3527 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3528 return "tr" . double_delim($from, $to) . $flags;
3531 # Like dq(), but different
3534 my ($op, $extended) = @_;
3536 my $type = $op->name;
3537 if ($type eq "const") {
3538 return '$[' if $op->private & OPpCONST_ARYBASE;
3539 my $unbacked = re_unback($self->const_sv($op)->as_string);
3540 return re_uninterp_extended(escape_extended_re($unbacked))
3542 return re_uninterp(escape_str($unbacked));
3543 } elsif ($type eq "concat") {
3544 my $first = $self->re_dq($op->first, $extended);
3545 my $last = $self->re_dq($op->last, $extended);
3547 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3548 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3549 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
3550 || ($last =~ /^[{\[\w_]/ &&
3551 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3553 return $first . $last;
3554 } elsif ($type eq "uc") {
3555 return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
3556 } elsif ($type eq "lc") {
3557 return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
3558 } elsif ($type eq "ucfirst") {
3559 return '\u' . $self->re_dq($op->first->sibling, $extended);
3560 } elsif ($type eq "lcfirst") {
3561 return '\l' . $self->re_dq($op->first->sibling, $extended);
3562 } elsif ($type eq "quotemeta") {
3563 return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
3564 } elsif ($type eq "join") {
3565 return $self->deparse($op->last, 26); # was join($", @ary)
3567 return $self->deparse($op, 26);
3572 my ($self, $op) = @_;
3573 my $type = $op->name;
3575 if ($type eq 'const') {
3578 elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
3579 return $self->pure_string($op->first->sibling);
3581 elsif ($type eq 'join') {
3582 my $join_op = $op->first->sibling; # Skip pushmark
3583 return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
3585 my $gvop = $join_op->first;
3586 return 0 unless $gvop->name eq 'gvsv';
3587 return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
3589 return 0 unless ${$join_op->sibling} eq ${$op->last};
3590 return 0 unless $op->last->name =~ /^(rv2|pad)av$/;
3592 elsif ($type eq 'concat') {
3593 return $self->pure_string($op->first)
3594 && $self->pure_string($op->last);
3596 elsif (is_scalar($op) || $type =~ /^[ah]elem(fast)?$/) {
3608 my($op, $cx, $extended) = @_;
3609 my $kid = $op->first;
3610 $kid = $kid->first if $kid->name eq "regcmaybe";
3611 $kid = $kid->first if $kid->name eq "regcreset";
3612 return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
3613 return ($self->deparse($kid, $cx), 0);
3617 my ($self, $op, $cx) = @_;
3618 return (($self->regcomp($op, $cx, 0))[0]);
3621 # osmic acid -- see osmium tetroxide
3624 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3625 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3626 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3630 my($op, $cx, $name, $delim) = @_;
3631 my $kid = $op->first;
3632 my ($binop, $var, $re) = ("", "", "");
3633 if ($op->flags & OPf_STACKED) {
3635 $var = $self->deparse($kid, 20);
3636 $kid = $kid->sibling;
3639 my $extended = ($op->pmflags & PMf_EXTENDED);
3641 my $unbacked = re_unback($op->precomp);
3643 $re = re_uninterp_extended(escape_extended_re($unbacked));
3645 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3647 } elsif ($kid->name ne 'regcomp') {
3648 Carp::cluck("found ".$kid->name." where regcomp expected");
3650 ($re, $quote) = $self->regcomp($kid, 1, $extended);
3653 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3654 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3655 $flags .= "i" if $op->pmflags & PMf_FOLD;
3656 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3657 $flags .= "o" if $op->pmflags & PMf_KEEP;
3658 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3659 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3660 $flags = $matchwords{$flags} if $matchwords{$flags};
3661 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3665 $re = single_delim($name, $delim, $re);
3667 $re = $re . $flags if $quote;
3669 return $self->maybe_parens("$var =~ $re", $cx, 20);
3675 sub pp_match { matchop(@_, "m", "/") }
3676 sub pp_pushre { matchop(@_, "m", "/") }
3677 sub pp_qr { matchop(@_, "qr", "") }
3682 my($kid, @exprs, $ary, $expr);
3684 if ($ {$kid->pmreplroot}) {
3685 $ary = $self->stash_variable('@', $self->gv_name($kid->pmreplroot));
3687 for (; !null($kid); $kid = $kid->sibling) {
3688 push @exprs, $self->deparse($kid, 6);
3691 # handle special case of split(), and split(" ") that compiles to /\s+/
3693 if ($kid->flags & OPf_SPECIAL
3694 && $exprs[0] eq '/\\s+/'
3695 && $kid->pmflags & PMf_SKIPWHITE ) {
3699 $expr = "split(" . join(", ", @exprs) . ")";
3701 return $self->maybe_parens("$ary = $expr", $cx, 7);
3707 # oxime -- any of various compounds obtained chiefly by the action of
3708 # hydroxylamine on aldehydes and ketones and characterized by the
3709 # bivalent grouping C=NOH [Webster's Tenth]
3712 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3713 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3714 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3715 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3720 my $kid = $op->first;
3721 my($binop, $var, $re, $repl) = ("", "", "", "");
3722 if ($op->flags & OPf_STACKED) {
3724 $var = $self->deparse($kid, 20);
3725 $kid = $kid->sibling;
3728 if (null($op->pmreplroot)) {
3729 $repl = $self->dq($kid);
3730 $kid = $kid->sibling;
3732 $repl = $op->pmreplroot->first; # skip substcont
3733 while ($repl->name eq "entereval") {
3734 $repl = $repl->first;
3737 if ($op->pmflags & PMf_EVAL) {
3738 $repl = $self->deparse($repl, 0);
3740 $repl = $self->dq($repl);
3743 my $extended = ($op->pmflags & PMf_EXTENDED);
3745 my $unbacked = re_unback($op->precomp);
3747 $re = re_uninterp_extended(escape_extended_re($unbacked));
3750 $re = re_uninterp(escape_str($unbacked));
3753 ($re) = $self->regcomp($kid, 1, $extended);
3755 $flags .= "e" if $op->pmflags & PMf_EVAL;
3756 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3757 $flags .= "i" if $op->pmflags & PMf_FOLD;
3758 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3759 $flags .= "o" if $op->pmflags & PMf_KEEP;
3760 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3761 $flags .= "x" if $extended;
3762 $flags = $substwords{$flags} if $substwords{$flags};
3764 return $self->maybe_parens("$var =~ s"
3765 . double_delim($re, $repl) . $flags,
3768 return "s". double_delim($re, $repl) . $flags;
3777 B::Deparse - Perl compiler backend to produce perl code
3781 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3782 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3786 B::Deparse is a backend module for the Perl compiler that generates
3787 perl source code, based on the internal compiled structure that perl
3788 itself creates after parsing a program. The output of B::Deparse won't
3789 be exactly the same as the original source, since perl doesn't keep
3790 track of comments or whitespace, and there isn't a one-to-one
3791 correspondence between perl's syntactical constructions and their
3792 compiled form, but it will often be close. When you use the B<-p>
3793 option, the output also includes parentheses even when they are not
3794 required by precedence, which can make it easy to see if perl is
3795 parsing your expressions the way you intended.
3797 Please note that this module is mainly new and untested code and is
3798 still under development, so it may change in the future.
3802 As with all compiler backend options, these must follow directly after
3803 the '-MO=Deparse', separated by a comma but not any white space.
3809 Add '#line' declarations to the output based on the line and file
3810 locations of the original code.
3814 Print extra parentheses. Without this option, B::Deparse includes
3815 parentheses in its output only when they are needed, based on the
3816 structure of your program. With B<-p>, it uses parentheses (almost)
3817 whenever they would be legal. This can be useful if you are used to
3818 LISP, or if you want to see how perl parses your input. If you say
3820 if ($var & 0x7f == 65) {print "Gimme an A!"}
3821 print ($which ? $a : $b), "\n";
3822 $name = $ENV{USER} or "Bob";
3824 C<B::Deparse,-p> will print
3827 print('Gimme an A!')
3829 (print(($which ? $a : $b)), '???');
3830 (($name = $ENV{'USER'}) or '???')
3832 which probably isn't what you intended (the C<'???'> is a sign that
3833 perl optimized away a constant value).
3837 Expand double-quoted strings into the corresponding combinations of
3838 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3841 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3845 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3846 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3848 Note that the expanded form represents the way perl handles such
3849 constructions internally -- this option actually turns off the reverse
3850 translation that B::Deparse usually does. On the other hand, note that
3851 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3852 of $y into a string before doing the assignment.
3856 Normally, B::Deparse deparses the main code of a program, and all the subs
3857 defined in the same file. To include subs defined in other files, pass the
3858 B<-f> option with the filename. You can pass the B<-f> option several times, to
3859 include more than one secondary file. (Most of the time you don't want to
3860 use it at all.) You can also use this option to include subs which are
3861 defined in the scope of a B<#line> directive with two parameters.
3863 =item B<-s>I<LETTERS>
3865 Tweak the style of B::Deparse's output. The letters should follow
3866 directly after the 's', with no space or punctuation. The following
3867 options are available:
3873 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3890 The default is not to cuddle.
3894 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3898 Use tabs for each 8 columns of indent. The default is to use only spaces.
3899 For instance, if the style options are B<-si4T>, a line that's indented
3900 3 times will be preceded by one tab and four spaces; if the options were
3901 B<-si8T>, the same line would be preceded by three tabs.
3903 =item B<v>I<STRING>B<.>
3905 Print I<STRING> for the value of a constant that can't be determined
3906 because it was optimized away (mnemonic: this happens when a constant
3907 is used in B<v>oid context). The end of the string is marked by a period.
3908 The string should be a valid perl expression, generally a constant.
3909 Note that unless it's a number, it probably needs to be quoted, and on
3910 a command line quotes need to be protected from the shell. Some
3911 conventional values include 0, 1, 42, '', 'foo', and
3912 'Useless use of constant omitted' (which may need to be
3913 B<-sv"'Useless use of constant omitted'.">
3914 or something similar depending on your shell). The default is '???'.
3915 If you're using B::Deparse on a module or other file that's require'd,
3916 you shouldn't use a value that evaluates to false, since the customary
3917 true constant at the end of a module will be in void context when the
3918 file is compiled as a main program.
3924 Expand conventional syntax constructions into equivalent ones that expose
3925 their internal operation. I<LEVEL> should be a digit, with higher values
3926 meaning more expansion. As with B<-q>, this actually involves turning off
3927 special cases in B::Deparse's normal operations.
3929 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3930 while loops with continue blocks; for instance
3932 for ($i = 0; $i < 10; ++$i) {
3945 Note that in a few cases this translation can't be perfectly carried back
3946 into the source code -- if the loop's initializer declares a my variable,
3947 for instance, it won't have the correct scope outside of the loop.
3949 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3950 expressions using C<&&>, C<?:> and C<do {}>; for instance
3952 print 'hi' if $nice;
3964 $nice and print 'hi';
3965 $nice and do { print 'hi' };
3966 $nice ? do { print 'hi' } : do { print 'bye' };
3968 Long sequences of elsifs will turn into nested ternary operators, which
3969 B::Deparse doesn't know how to indent nicely.
3973 =head1 USING B::Deparse AS A MODULE
3978 $deparse = B::Deparse->new("-p", "-sC");
3979 $body = $deparse->coderef2text(\&func);
3980 eval "sub func $body"; # the inverse operation
3984 B::Deparse can also be used on a sub-by-sub basis from other perl
3989 $deparse = B::Deparse->new(OPTIONS)
3991 Create an object to store the state of a deparsing operation and any
3992 options. The options are the same as those that can be given on the
3993 command line (see L</OPTIONS>); options that are separated by commas
3994 after B<-MO=Deparse> should be given as separate strings. Some
3995 options, like B<-u>, don't make sense for a single subroutine, so
3998 =head2 ambient_pragmas
4000 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
4002 The compilation of a subroutine can be affected by a few compiler
4003 directives, B<pragmas>. These are:
4017 Assigning to the special variable $[
4037 Ordinarily, if you use B::Deparse on a subroutine which has
4038 been compiled in the presence of one or more of these pragmas,
4039 the output will include statements to turn on the appropriate
4040 directives. So if you then compile the code returned by coderef2text,
4041 it will behave the same way as the subroutine which you deparsed.
4043 However, you may know that you intend to use the results in a
4044 particular context, where some pragmas are already in scope. In
4045 this case, you use the B<ambient_pragmas> method to describe the
4046 assumptions you wish to make.
4048 Not all of the options currently have any useful effect. See
4049 L</BUGS> for more details.
4051 The parameters it accepts are:
4057 Takes a string, possibly containing several values separated
4058 by whitespace. The special values "all" and "none" mean what you'd
4061 $deparse->ambient_pragmas(strict => 'subs refs');
4065 Takes a number, the value of the array base $[.
4073 If the value is true, then the appropriate pragma is assumed to
4074 be in the ambient scope, otherwise not.
4078 Takes a string, possibly containing a whitespace-separated list of
4079 values. The values "all" and "none" are special. It's also permissible
4080 to pass an array reference here.
4082 $deparser->ambient_pragmas(re => 'eval');
4087 Takes a string, possibly containing a whitespace-separated list of
4088 values. The values "all" and "none" are special, again. It's also
4089 permissible to pass an array reference here.
4091 $deparser->ambient_pragmas(warnings => [qw[void io]]);
4093 If one of the values is the string "FATAL", then all the warnings
4094 in that list will be considered fatal, just as with the B<warnings>
4095 pragma itself. Should you need to specify that some warnings are
4096 fatal, and others are merely enabled, you can pass the B<warnings>
4099 $deparser->ambient_pragmas(
4101 warnings => [FATAL => qw/void io/],
4104 See L<perllexwarn> for more information about lexical warnings.
4110 These two parameters are used to specify the ambient pragmas in
4111 the format used by the special variables $^H and ${^WARNING_BITS}.
4113 They exist principally so that you can write code like:
4115 { my ($hint_bits, $warning_bits);
4116 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
4117 $deparser->ambient_pragmas (
4118 hint_bits => $hint_bits,
4119 warning_bits => $warning_bits,
4123 which specifies that the ambient pragmas are exactly those which
4124 are in scope at the point of calling.
4130 $body = $deparse->coderef2text(\&func)
4131 $body = $deparse->coderef2text(sub ($$) { ... })
4133 Return source code for the body of a subroutine (a block, optionally
4134 preceded by a prototype in parens), given a reference to the
4135 sub. Because a subroutine can have no names, or more than one name,
4136 this method doesn't return a complete subroutine definition -- if you
4137 want to eval the result, you should prepend "sub subname ", or "sub "
4138 for an anonymous function constructor. Unless the sub was defined in
4139 the main:: package, the code will include a package declaration.
4147 The only pragmas to be completely supported are: C<use warnings>,
4148 C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
4149 behaves like a pragma, is also supported.)
4151 Excepting those listed above, we're currently unable to guarantee that
4152 B::Deparse will produce a pragma at the correct point in the program.
4153 Since the effects of pragmas are often lexically scoped, this can mean
4154 that the pragma holds sway over a different portion of the program
4155 than in the input file.
4159 In fact, the above is a specific instance of a more general problem:
4160 we can't guarantee to produce BEGIN blocks or C<use> declarations in
4161 exactly the right place. So if you use a module which affects compilation
4162 (such as by over-riding keywords, overloading constants or whatever)
4163 then the output code might not work as intended.
4165 This is the most serious outstanding problem, and will be very hard
4170 If a keyword is over-ridden, and your program explicitly calls
4171 the built-in version by using CORE::keyword, the output of B::Deparse
4172 will not reflect this. If you run the resulting code, it will call
4173 the over-ridden version rather than the built-in one. (Maybe there
4174 should be an option to B<always> print keyword calls as C<CORE::name>.)
4178 C<sort foo (1, 2, 3)> comes out as C<sort (foo 1, 2, 3)>, which
4179 causes perl to issue a warning.
4181 The obvious fix doesn't work, because these are different:
4183 print (FOO 1, 2, 3), 4, 5, 6;
4184 print FOO (1, 2, 3), 4, 5, 6;
4188 Constants (other than simple strings or numbers) don't work properly.
4189 Pathological examples that fail (and probably always will) include:
4191 use constant E2BIG => ($!=7);
4192 use constant x=>\$x; print x
4194 The following could (and should) be made to work:
4196 use constant regex => qr/blah/;
4201 An input file that uses source filtering probably won't be deparsed into
4202 runnable code, because it will still include the B<use> declaration
4203 for the source filtering module, even though the code that is
4204 produced is already ordinary Perl which shouldn't be filtered again.
4208 There are probably many more bugs on non-ASCII platforms (EBCDIC).
4214 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
4215 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
4216 contributions from Gisle Aas, James Duncan, Albert Dvornik, Robin
4217 Houston, Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons,
4218 and Rafael Garcia-Suarez.