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.
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);
24 use vars qw/$AUTOLOAD/;
27 # Changes between 0.50 and 0.51:
28 # - fixed nulled leave with live enter in sort { }
29 # - fixed reference constants (\"str")
30 # - handle empty programs gracefully
31 # - handle infinte loops (for (;;) {}, while (1) {})
32 # - differentiate between `for my $x ...' and `my $x; for $x ...'
33 # - various minor cleanups
34 # - moved globals into an object
35 # - added `-u', like B::C
36 # - package declarations using cop_stash
37 # - subs, formats and code sorted by cop_seq
38 # Changes between 0.51 and 0.52:
39 # - added pp_threadsv (special variables under USE_5005THREADS)
40 # - added documentation
41 # Changes between 0.52 and 0.53:
42 # - many changes adding precedence contexts and associativity
43 # - added `-p' and `-s' output style options
44 # - various other minor fixes
45 # Changes between 0.53 and 0.54:
46 # - added support for new `for (1..100)' optimization,
48 # Changes between 0.54 and 0.55:
49 # - added support for new qr// construct
50 # - added support for new pp_regcreset OP
51 # Changes between 0.55 and 0.56:
52 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
53 # - fixed $# on non-lexicals broken in last big rewrite
54 # - added temporary fix for change in opcode of OP_STRINGIFY
55 # - fixed problem in 0.54's for() patch in `for (@ary)'
56 # - fixed precedence in conditional of ?:
57 # - tweaked list paren elimination in `my($x) = @_'
58 # - made continue-block detection trickier wrt. null ops
59 # - fixed various prototype problems in pp_entersub
60 # - added support for sub prototypes that never get GVs
61 # - added unquoting for special filehandle first arg in truncate
62 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
63 # - added semicolons at the ends of blocks
64 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
65 # Changes between 0.56 and 0.561:
66 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
67 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
68 # Changes between 0.561 and 0.57:
69 # - stylistic changes to symbolic constant stuff
70 # - handled scope in s///e replacement code
71 # - added unquote option for expanding "" into concats, etc.
72 # - split method and proto parts of pp_entersub into separate functions
73 # - various minor cleanups
75 # - added parens in \&foo (patch by Albert Dvornik)
76 # Changes between 0.57 and 0.58:
77 # - fixed `0' statements that weren't being printed
78 # - added methods for use from other programs
79 # (based on patches from James Duncan and Hugo van der Sanden)
80 # - added -si and -sT to control indenting (also based on a patch from Hugo)
81 # - added -sv to print something else instead of '???'
82 # - preliminary version of utf8 tr/// handling
84 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
85 # - added support for Hugo's new OP_SETSTATE (like nextstate)
86 # Changes between 0.58 and 0.59
87 # - added support for Chip's OP_METHOD_NAMED
88 # - added support for Ilya's OPpTARGET_MY optimization
89 # - elided arrows before `()' subscripts when possible
90 # Changes between 0.59 and 0.60
91 # - support for method attribues was added
92 # - some warnings fixed
93 # - separate recognition of constant subs
94 # - rewrote continue block handling, now recoginizing for loops
95 # - added more control of expanding control structures
96 # Changes between 0.60 and 0.61 (mostly by Robin Houston)
98 # - support for pragmas and 'use'
99 # - support for the little-used $[ variable
100 # - support for __DATA__ sections
102 # - BEGIN, CHECK, INIT and END blocks
103 # - scoping of subroutine declarations fixed
104 # - compile-time output from the input program can be suppressed, so that the
105 # output is just the deparsed code. (a change to O.pm in fact)
106 # - our() declarations
107 # - *all* the known bugs are now listed in the BUGS section
108 # - comprehensive test mechanism (TEST -deparse)
111 # (See also BUGS section at the end of this file)
113 # - finish tr/// changes
114 # - add option for even more parens (generalize \&foo change)
115 # - left/right context
116 # - treat top-level block specially for incremental output
117 # - copy comments (look at real text with $^P?)
118 # - avoid semis in one-statement blocks
119 # - associativity of &&=, ||=, ?:
120 # - ',' => '=>' (auto-unquote?)
121 # - break long lines ("\r" as discretionary break?)
122 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
123 # - more style options: brace style, hex vs. octal, quotes, ...
124 # - print big ints as hex/octal instead of decimal (heuristic?)
125 # - handle `my $x if 0'?
126 # - coordinate with Data::Dumper (both directions? see previous)
127 # - version using op_next instead of op_first/sibling?
128 # - avoid string copies (pass arrays, one big join?)
131 # Tests that will always fail:
132 # (see t/TEST for the short list)
134 # Object fields (were globals):
137 # (local($a), local($b)) and local($a, $b) have the same internal
138 # representation but the short form looks better. We notice we can
139 # use a large-scale local when checking the list, but need to prevent
140 # individual locals too. This hash holds the addresses of OPs that
141 # have already had their local-ness accounted for. The same thing
145 # CV for current sub (or main program) being deparsed
148 # Cached hash of lexical variables for curcv: keys are names,
149 # each value is an array of pairs, indicating the cop_seq of scopes
150 # in which a var of that name is valid.
153 # COP for statement being deparsed
156 # name of the current package for deparsed code
159 # array of [cop_seq, CV, is_format?] for subs and formats we still
163 # as above, but [name, prototype] for subs that never got a GV
165 # subs_done, forms_done:
166 # keys are addresses of GVs for subs and formats we've already
167 # deparsed (or at least put into subs_todo)
170 # keys are names of subs for which we've printed declarations.
171 # That means we can omit parentheses from the arguments.
174 # Keeps track of fully qualified names of all deparsed subs.
179 # cuddle: ` ' or `\n', depending on -sC
184 # A little explanation of how precedence contexts and associativity
187 # deparse() calls each per-op subroutine with an argument $cx (short
188 # for context, but not the same as the cx* in the perl core), which is
189 # a number describing the op's parents in terms of precedence, whether
190 # they're inside an expression or at statement level, etc. (see
191 # chart below). When ops with children call deparse on them, they pass
192 # along their precedence. Fractional values are used to implement
193 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
194 # parentheses hacks. The major disadvantage of this scheme is that
195 # it doesn't know about right sides and left sides, so say if you
196 # assign a listop to a variable, it can't tell it's allowed to leave
197 # the parens off the listop.
200 # 26 [TODO] inside interpolation context ("")
201 # 25 left terms and list operators (leftward)
205 # 21 right ! ~ \ and unary + and -
210 # 16 nonassoc named unary operators
211 # 15 nonassoc < > <= >= lt gt le ge
212 # 14 nonassoc == != <=> eq ne cmp
219 # 7 right = += -= *= etc.
221 # 5 nonassoc list operators (rightward)
225 # 1 statement modifiers
228 # Also, lineseq may pass a fourth parameter to the pp_ routines:
229 # if present, the fourth parameter is passed on by deparse.
231 # If present and true, it means that the op exists directly as
232 # part of a lineseq. Currently it's only used by scopeop to
233 # decide whether its results need to be enclosed in a do {} block.
235 # Nonprinting characters with special meaning:
236 # \cS - steal parens (see maybe_parens_unop)
237 # \n - newline and indent
238 # \t - increase indent
239 # \b - decrease indent (`outdent')
240 # \f - flush left (no indent)
241 # \cK - kill following semicolon, if any
245 return class($op) eq "NULL";
250 my($cv, $is_form) = @_;
251 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
253 if (!null($cv->START) and is_state($cv->START)) {
254 $seq = $cv->START->cop_seq;
258 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
259 unless ($is_form || class($cv->STASH) eq 'SPECIAL') {
260 $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1;
266 my $ent = shift @{$self->{'subs_todo'}};
269 my $name = $self->gv_name($gv);
271 return "format $name =\n"
272 . $self->deparse_format($ent->[1]). "\n";
274 $self->{'subs_declared'}{$name} = 1;
275 if ($name eq "BEGIN") {
276 my $use_dec = $self->begin_is_use($cv);
277 if (defined ($use_dec)) {
278 return () if 0 == length($use_dec);
283 if ($self->{'linenums'}) {
284 my $line = $gv->LINE;
285 my $file = $gv->FILE;
286 $l = "\n\f#line $line \"$file\"\n";
288 return "${l}sub $name " . $self->deparse_sub($cv);
292 # Return a "use" declaration for this BEGIN block, if appropriate
294 my ($self, $cv) = @_;
295 my $root = $cv->ROOT;
296 local @$self{qw'curcv curcvlex'} = ($cv);
298 #B::walkoptree($cv->ROOT, "debug");
299 my $lineseq = $root->first;
300 return if $lineseq->name ne "lineseq";
302 my $req_op = $lineseq->first->sibling;
303 return if $req_op->name ne "require";
306 if ($req_op->first->private & OPpCONST_BARE) {
307 # Actually it should always be a bareword
308 $module = $self->const_sv($req_op->first)->PV;
309 $module =~ s[/][::]g;
313 $module = const($self->const_sv($req_op->first));
317 my $version_op = $req_op->sibling;
318 return if class($version_op) eq "NULL";
319 if ($version_op->name eq "lineseq") {
320 # We have a version parameter; skip nextstate & pushmark
321 my $constop = $version_op->first->next->next;
323 return unless $self->const_sv($constop)->PV eq $module;
324 $constop = $constop->sibling;
325 $version = $self->const_sv($constop)->int_value;
326 $constop = $constop->sibling;
327 return if $constop->name ne "method_named";
328 return if $self->const_sv($constop)->PV ne "VERSION";
331 $lineseq = $version_op->sibling;
332 return if $lineseq->name ne "lineseq";
333 my $entersub = $lineseq->first->sibling;
334 if ($entersub->name eq "stub") {
335 return "use $module $version ();\n" if defined $version;
336 return "use $module ();\n";
338 return if $entersub->name ne "entersub";
340 # See if there are import arguments
343 my $svop = $entersub->first->sibling; # Skip over pushmark
344 return unless $self->const_sv($svop)->PV eq $module;
346 # Pull out the arguments
347 for ($svop=$svop->sibling; $svop->name ne "method_named";
348 $svop = $svop->sibling) {
349 $args .= ", " if length($args);
350 $args .= $self->deparse($svop, 6);
354 my $method_named = $svop;
355 return if $method_named->name ne "method_named";
356 my $method_name = $self->const_sv($method_named)->PV;
358 if ($method_name eq "unimport") {
362 # Certain pragmas are dealt with using hint bits,
363 # so we ignore them here
364 if ($module eq 'strict' || $module eq 'integer'
365 || $module eq 'bytes' || $module eq 'warnings') {
369 if (defined $version && length $args) {
370 return "$use $module $version ($args);\n";
371 } elsif (defined $version) {
372 return "$use $module $version;\n";
373 } elsif (length $args) {
374 return "$use $module ($args);\n";
376 return "$use $module;\n";
381 my ($self, $pack) = @_;
383 if (!defined $pack) {
388 $pack =~ s/(::)?$/::/;
392 my %stash = svref_2object($stash)->ARRAY;
393 while (my ($key, $val) = each %stash) {
394 next if $key eq 'main::'; # avoid infinite recursion
395 my $class = class($val);
396 if ($class eq "PV") {
397 # Just a prototype. As an ugly but fairly effective way
398 # to find out if it belongs here is to see if the AUTOLOAD
399 # (if any) for the stash was defined in one of our files.
400 my $A = $stash{"AUTOLOAD"};
401 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
402 && class($A->CV) eq "CV") {
404 next unless $AF eq $0 || exists $self->{'files'}{$AF};
406 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
407 } elsif ($class eq "IV") {
408 # Just a name. As above.
409 my $A = $stash{"AUTOLOAD"};
410 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
411 && class($A->CV) eq "CV") {
413 next unless $AF eq $0 || exists $self->{'files'}{$AF};
415 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
416 } elsif ($class eq "GV") {
417 if (class(my $cv = $val->CV) ne "SPECIAL") {
418 next if $self->{'subs_done'}{$$val}++;
419 next if $$val != ${$cv->GV}; # Ignore imposters
422 if (class(my $cv = $val->FORM) ne "SPECIAL") {
423 next if $self->{'forms_done'}{$$val}++;
424 next if $$val != ${$cv->GV}; # Ignore imposters
427 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
428 $self->stash_subs($pack . $key);
438 foreach $ar (@{$self->{'protos_todo'}}) {
439 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
440 push @ret, "sub " . $ar->[0] . "$proto;\n";
442 delete $self->{'protos_todo'};
450 while (length($opt = substr($opts, 0, 1))) {
452 $self->{'cuddle'} = " ";
453 $opts = substr($opts, 1);
454 } elsif ($opt eq "i") {
455 $opts =~ s/^i(\d+)//;
456 $self->{'indent_size'} = $1;
457 } elsif ($opt eq "T") {
458 $self->{'use_tabs'} = 1;
459 $opts = substr($opts, 1);
460 } elsif ($opt eq "v") {
461 $opts =~ s/^v([^.]*)(.|$)//;
462 $self->{'ex_const'} = $1;
469 my $self = bless {}, $class;
470 $self->{'subs_todo'} = [];
471 $self->{'files'} = {};
472 $self->{'curstash'} = "main";
473 $self->{'curcop'} = undef;
474 $self->{'cuddle'} = "\n";
475 $self->{'indent_size'} = 4;
476 $self->{'use_tabs'} = 0;
477 $self->{'expand'} = 0;
478 $self->{'unquote'} = 0;
479 $self->{'linenums'} = 0;
480 $self->{'parens'} = 0;
481 $self->{'ex_const'} = "'???'";
483 $self->{'ambient_arybase'} = 0;
484 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
485 $self->{'ambient_hints'} = 0;
488 while (my $arg = shift @_) {
489 if ($arg =~ /^-f(.*)/) {
490 $self->{'files'}{$1} = 1;
491 } elsif ($arg eq "-p") {
492 $self->{'parens'} = 1;
493 } elsif ($arg eq "-P") {
494 $self->{'noproto'} = 1;
495 } elsif ($arg eq "-l") {
496 $self->{'linenums'} = 1;
497 } elsif ($arg eq "-q") {
498 $self->{'unquote'} = 1;
499 } elsif (substr($arg, 0, 2) eq "-s") {
500 $self->style_opts(substr $arg, 2);
501 } elsif ($arg =~ /^-x(\d)$/) {
502 $self->{'expand'} = $1;
509 # Mask out the bits that L<warnings::register> uses
512 $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
519 # Initialise the contextual information, either from
520 # defaults provided with the ambient_pragmas method,
521 # or from perl's own defaults otherwise.
525 $self->{'arybase'} = $self->{'ambient_arybase'};
526 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
527 ? $self->{'ambient_warnings'} & WARN_MASK
529 $self->{'hints'} = $self->{'ambient_hints'} & 0xFF;
531 # also a convenient place to clear out subs_declared
532 delete $self->{'subs_declared'};
538 my $self = B::Deparse->new(@args);
539 # First deparse command-line args
540 if (defined $^I) { # deparse -i
541 print q(BEGIN { $^I = ).cstring($^I).qq(; }\n);
543 if ($^W) { # deparse -w
544 print qq(BEGIN { \$^W = $^W; }\n);
546 if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
547 my $fs = cstring($/) || 'undef';
548 my $bs = cstring($O::savebackslash) || 'undef';
549 print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
551 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
552 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
553 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
554 for my $block (@BEGINs, @INITs, @ENDs) {
555 $self->todo($block, 0);
558 $self->{'curcv'} = main_cv;
559 $self->{'curcvlex'} = undef;
560 print $self->print_protos;
561 @{$self->{'subs_todo'}} =
562 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
563 print $self->indent($self->deparse(main_root, 0)), "\n"
564 unless null main_root;
566 while (scalar(@{$self->{'subs_todo'}})) {
567 push @text, $self->next_todo;
569 print $self->indent(join("", @text)), "\n" if @text;
571 # Print __DATA__ section, if necessary
573 my $laststash = defined $self->{'curcop'}
574 ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
575 if (defined *{$laststash."::DATA"}{IO}) {
577 print readline(*{$laststash."::DATA"});
585 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
588 return $self->indent($self->deparse_sub(svref_2object($sub)));
591 sub ambient_pragmas {
593 my ($arybase, $hint_bits, $warning_bits) = (0, 0);
599 if ($name eq 'strict') {
602 if ($val eq 'none') {
603 $hint_bits &= ~strict::bits(qw/refs subs vars/);
609 @names = qw/refs subs vars/;
615 @names = split' ', $val;
617 $hint_bits |= strict::bits(@names);
620 elsif ($name eq '$[') {
624 elsif ($name eq 'integer'
626 || $name eq 'utf8') {
629 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
632 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
636 elsif ($name eq 're') {
638 if ($val eq 'none') {
639 $hint_bits &= ~re::bits(qw/taint eval/);
645 @names = qw/taint eval/;
651 @names = split' ',$val;
653 $hint_bits |= re::bits(@names);
656 elsif ($name eq 'warnings') {
657 if ($val eq 'none') {
658 $warning_bits = $warnings::NONE;
667 @names = split/\s+/, $val;
670 $warning_bits = $warnings::NONE if !defined ($warning_bits);
671 $warning_bits |= warnings::bits(@names);
674 elsif ($name eq 'warning_bits') {
675 $warning_bits = $val;
678 elsif ($name eq 'hint_bits') {
683 croak "Unknown pragma type: $name";
687 croak "The ambient_pragmas method expects an even number of args";
690 $self->{'ambient_arybase'} = $arybase;
691 $self->{'ambient_warnings'} = $warning_bits;
692 $self->{'ambient_hints'} = $hint_bits;
697 my($op, $cx, $flags) = @_;
699 Carp::confess("Null op in deparse") if !defined($op)
700 || class($op) eq "NULL";
701 my $meth = "pp_" . $op->name;
703 return $self->$meth($op, $cx, $flags);
705 return $self->$meth($op, $cx);
711 my @lines = split(/\n/, $txt);
716 my $cmd = substr($line, 0, 1);
717 if ($cmd eq "\t" or $cmd eq "\b") {
718 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
719 if ($self->{'use_tabs'}) {
720 $leader = "\t" x ($level / 8) . " " x ($level % 8);
722 $leader = " " x $level;
724 $line = substr($line, 1);
726 if (substr($line, 0, 1) eq "\f") {
727 $line = substr($line, 1); # no indent
729 $line = $leader . $line;
733 return join("\n", @lines);
740 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
741 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
742 local $self->{'curcop'} = $self->{'curcop'};
743 if ($cv->FLAGS & SVf_POK) {
744 $proto = "(". $cv->PV . ") ";
746 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
748 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
749 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
750 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
753 local($self->{'curcv'}) = $cv;
754 local($self->{'curcvlex'});
755 local(@$self{qw'curstash warnings hints'})
756 = @$self{qw'curstash warnings hints'};
758 if (not null $cv->ROOT) {
759 my $lineseq = $cv->ROOT->first;
760 if ($lineseq->name eq "lineseq") {
762 for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
765 $body = $self->lineseq(undef, @ops).";";
766 my $scope_en = $self->find_scope_en($lineseq);
767 if (defined $scope_en) {
768 my $subs = join"", $self->seq_subs($scope_en);
769 $body .= ";\n$subs" if length($subs);
773 $body = $self->deparse($cv->ROOT->first, 0);
777 my $sv = $cv->const_sv;
779 # uh-oh. inlinable sub... format it differently
780 return $proto . "{ " . const($sv) . " }\n";
781 } else { # XSUB? (or just a declaration)
785 return $proto ."{\n\t$body\n\b}" ."\n";
792 local($self->{'curcv'}) = $form;
793 local($self->{'curcvlex'});
794 local($self->{'in_format'}) = 1;
795 local(@$self{qw'curstash warnings hints'})
796 = @$self{qw'curstash warnings hints'};
797 my $op = $form->ROOT;
799 return "\f." if $op->first->name eq 'stub';
800 $op = $op->first->first; # skip leavewrite, lineseq
801 while (not null $op) {
802 $op = $op->sibling; # skip nextstate
804 $kid = $op->first->sibling; # skip pushmark
805 push @text, "\f".$self->const_sv($kid)->PV;
806 $kid = $kid->sibling;
807 for (; not null $kid; $kid = $kid->sibling) {
808 push @exprs, $self->deparse($kid, 0);
810 push @text, "\f".join(", ", @exprs)."\n" if @exprs;
813 return join("", @text) . "\f.";
818 return $op->name eq "leave" || $op->name eq "scope"
819 || $op->name eq "lineseq"
820 || ($op->name eq "null" && class($op) eq "UNOP"
821 && (is_scope($op->first) || $op->first->name eq "enter"));
825 my $name = $_[0]->name;
826 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
829 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
831 return (!null($op) and null($op->sibling)
832 and $op->name eq "null" and class($op) eq "UNOP"
833 and (($op->first->name =~ /^(and|or)$/
834 and $op->first->first->sibling->name eq "lineseq")
835 or ($op->first->name eq "lineseq"
836 and not null $op->first->first->sibling
837 and $op->first->first->sibling->name eq "unstack")
843 return ($op->name eq "rv2sv" or
844 $op->name eq "padsv" or
845 $op->name eq "gv" or # only in array/hash constructs
846 $op->flags & OPf_KIDS && !null($op->first)
847 && $op->first->name eq "gvsv");
852 my($text, $cx, $prec) = @_;
853 if ($prec < $cx # unary ops nest just fine
854 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
855 or $self->{'parens'})
858 # In a unop, let parent reuse our parens; see maybe_parens_unop
859 $text = "\cS" . $text if $cx == 16;
866 # same as above, but get around the `if it looks like a function' rule
867 sub maybe_parens_unop {
869 my($name, $kid, $cx) = @_;
870 if ($cx > 16 or $self->{'parens'}) {
871 $kid = $self->deparse($kid, 1);
872 if ($name eq "umask" && $kid =~ /^\d+$/) {
873 $kid = sprintf("%#o", $kid);
875 return "$name($kid)";
877 $kid = $self->deparse($kid, 16);
878 if ($name eq "umask" && $kid =~ /^\d+$/) {
879 $kid = sprintf("%#o", $kid);
881 if (substr($kid, 0, 1) eq "\cS") {
883 return $name . substr($kid, 1);
884 } elsif (substr($kid, 0, 1) eq "(") {
885 # avoid looks-like-a-function trap with extra parens
886 # (`+' can lead to ambiguities)
887 return "$name(" . $kid . ")";
894 sub maybe_parens_func {
896 my($func, $text, $cx, $prec) = @_;
897 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
898 return "$func($text)";
900 return "$func $text";
906 my($op, $cx, $text) = @_;
907 my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
908 if ($op->private & (OPpLVAL_INTRO|$our_intro)
909 and not $self->{'avoid_local'}{$$op}) {
910 my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
911 if (want_scalar($op)) {
912 return "$our_local $text";
914 return $self->maybe_parens_func("$our_local", $text, $cx, 16);
923 my($op, $cx, $func, @args) = @_;
924 if ($op->private & OPpTARGET_MY) {
925 my $var = $self->padname($op->targ);
926 my $val = $func->($self, $op, 7, @args);
927 return $self->maybe_parens("$var = $val", $cx, 7);
929 return $func->($self, $op, $cx, @args);
936 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
941 my($op, $cx, $text) = @_;
942 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
943 if (want_scalar($op)) {
946 return $self->maybe_parens_func("my", $text, $cx, 16);
953 # The following OPs don't have functions:
955 # pp_padany -- does not exist after parsing
958 if ($AUTOLOAD =~ s/^.*::pp_//) {
959 warn "unexpected OP_".uc $AUTOLOAD;
962 die "Undefined subroutine $AUTOLOAD called";
966 # $root should be the op which represents the root of whatever
967 # we're sequencing here. If it's undefined, then we don't append
968 # any subroutine declarations to the deparsed ops, otherwise we
969 # append appropriate declarations.
971 my($self, $root, @ops) = @_;
974 my $out_cop = $self->{'curcop'};
975 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
978 $limit_seq = $out_seq;
979 my $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
980 $limit_seq = $nseq if !defined($limit_seq)
981 or defined($nseq) && $nseq < $limit_seq;
983 $limit_seq = $self->{'limit_seq'}
984 if defined($self->{'limit_seq'})
985 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
986 local $self->{'limit_seq'} = $limit_seq;
987 for (my $i = 0; $i < @ops; $i++) {
989 if (is_state $ops[$i]) {
990 $expr = $self->deparse($ops[$i], 0);
997 if (!is_state $ops[$i] and (my $ls = $ops[$i+1]) and
998 !null($ops[$i+1]) and $ops[$i+1]->name eq "lineseq")
1000 if ($ls->first && !null($ls->first) && is_state($ls->first)
1001 && (my $sib = $ls->first->sibling)) {
1002 if (!null($sib) && $sib->name eq "leaveloop") {
1003 push @exprs, $expr . $self->for_loop($ops[$i], 0);
1009 $expr .= $self->deparse($ops[$i], 0, (@ops != 1));
1010 $expr =~ s/;\n?\z//;
1013 my $body = join(";\n", grep {length} @exprs);
1015 if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
1016 $subs = join "\n", $self->seq_subs($limit_seq);
1018 return join(";\n", grep {length} $body, $subs);
1022 my($real_block, $self, $op, $cx, $flags) = @_;
1026 local(@$self{qw'curstash warnings hints'})
1027 = @$self{qw'curstash warnings hints'} if $real_block;
1029 $kid = $op->first->sibling; # skip enter
1030 if (is_miniwhile($kid)) {
1031 my $top = $kid->first;
1032 my $name = $top->name;
1033 if ($name eq "and") {
1035 } elsif ($name eq "or") {
1037 } else { # no conditional -> while 1 or until 0
1038 return $self->deparse($top->first, 1) . " while 1";
1040 my $cond = $top->first;
1041 my $body = $cond->sibling->first; # skip lineseq
1042 $cond = $self->deparse($cond, 1);
1043 $body = $self->deparse($body, 1);
1044 return "$body $name $cond";
1049 for (; !null($kid); $kid = $kid->sibling) {
1052 if ($flags || $cx > 0) { # inside an expression, (a do {} while for lineseq)
1053 return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
1055 my $lineseq = $self->lineseq($op, @kids);
1056 return (length ($lineseq) ? "$lineseq;" : "");
1060 sub pp_scope { scopeop(0, @_); }
1061 sub pp_lineseq { scopeop(0, @_); }
1062 sub pp_leave { scopeop(1, @_); }
1064 # The BEGIN {} is used here because otherwise this code isn't executed
1065 # when you run B::Deparse on itself.
1067 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1068 "ENV", "ARGV", "ARGVOUT", "_"); }
1073 Carp::confess() if $gv->isa("B::CV");
1074 my $stash = $gv->STASH->NAME;
1075 my $name = $gv->SAFENAME;
1076 if ($stash eq $self->{'curstash'} or $globalnames{$name}
1077 or $name =~ /^[^A-Za-z_]/)
1081 $stash = $stash . "::";
1083 if ($name =~ /^(\^..|{)/) {
1084 $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
1086 return $stash . $name;
1089 # Return the name to use for a stash variable.
1090 # If a lexical with the same name is in scope, it may need to be
1092 sub stash_variable {
1093 my ($self, $prefix, $name) = @_;
1095 return "$prefix$name" if $name =~ /::/;
1097 unless ($prefix eq '$' || $prefix eq '@' ||
1098 $prefix eq '%' || $prefix eq '$#') {
1099 return "$prefix$name";
1102 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1103 return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
1104 return "$prefix$name";
1108 my ($self, $name) = @_;
1109 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1111 return 0 if !defined($self->{'curcop'});
1112 my $seq = $self->{'curcop'}->cop_seq;
1113 return 0 if !exists $self->{'curcvlex'}{$name};
1114 for my $a (@{$self->{'curcvlex'}{$name}}) {
1115 my ($st, $en) = @$a;
1116 return 1 if $seq > $st && $seq <= $en;
1121 sub populate_curcvlex {
1123 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1124 my @padlist = $cv->PADLIST->ARRAY;
1125 my @ns = $padlist[0]->ARRAY;
1127 for (my $i=0; $i<@ns; ++$i) {
1128 next if class($ns[$i]) eq "SPECIAL";
1129 next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars
1130 if (class($ns[$i]) eq "PV") {
1131 # Probably that pesky lexical @_
1134 my $name = $ns[$i]->PVX;
1135 my $seq_st = $ns[$i]->NVX;
1136 my $seq_en = int($ns[$i]->IVX);
1138 push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
1143 sub find_scope_st { ((find_scope(@_))[0]); }
1144 sub find_scope_en { ((find_scope(@_))[1]); }
1146 # Recurses down the tree, looking for pad variable introductions and COPs
1148 my ($self, $op, $scope_st, $scope_en) = @_;
1149 carp("Undefined op in find_scope") if !defined $op;
1150 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1152 for (my $o=$op->first; $$o; $o=$o->sibling) {
1153 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1154 my $s = int($self->padname_sv($o->targ)->NVX);
1155 my $e = $self->padname_sv($o->targ)->IVX;
1156 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1157 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1159 elsif (is_state($o)) {
1160 my $c = $o->cop_seq;
1161 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1162 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1164 elsif ($o->flags & OPf_KIDS) {
1165 ($scope_st, $scope_en) =
1166 $self->find_scope($o, $scope_st, $scope_en)
1170 return ($scope_st, $scope_en);
1173 # Returns a list of subs which should be inserted before the COP
1175 my ($self, $op, $out_seq) = @_;
1176 my $seq = $op->cop_seq;
1177 # If we have nephews, then our sequence number indicates
1178 # the cop_seq of the end of some sort of scope.
1179 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1180 and my $nseq = $self->find_scope_st($op->sibling) ) {
1183 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1184 return $self->seq_subs($seq);
1188 my ($self, $seq) = @_;
1190 #push @text, "# ($seq)\n";
1192 return "" if !defined $seq;
1193 while (scalar(@{$self->{'subs_todo'}})
1194 and $seq > $self->{'subs_todo'}[0][0]) {
1195 push @text, $self->next_todo;
1200 # Notice how subs and formats are inserted between statements here;
1201 # also $[ assignments and pragmas.
1205 $self->{'curcop'} = $op;
1207 push @text, $self->cop_subs($op);
1208 push @text, $op->label . ": " if $op->label;
1209 my $stash = $op->stashpv;
1210 if ($stash ne $self->{'curstash'}) {
1211 push @text, "package $stash;\n";
1212 $self->{'curstash'} = $stash;
1214 if ($self->{'linenums'}) {
1215 push @text, "\f#line " . $op->line .
1216 ' "' . $op->file, qq'"\n';
1219 if ($self->{'arybase'} != $op->arybase) {
1220 push @text, '$[ = '. $op->arybase .";\n";
1221 $self->{'arybase'} = $op->arybase;
1224 my $warnings = $op->warnings;
1226 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1227 $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
1229 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1230 $warning_bits = $warnings::NONE;
1232 elsif ($warnings->isa("B::SPECIAL")) {
1233 $warning_bits = undef;
1236 $warning_bits = $warnings->PV & WARN_MASK;
1239 if (defined ($warning_bits) and
1240 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1241 push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1242 $self->{'warnings'} = $warning_bits;
1245 if ($self->{'hints'} != $op->private) {
1246 push @text, declare_hints($self->{'hints'}, $op->private);
1247 $self->{'hints'} = $op->private;
1250 return join("", @text);
1253 sub declare_warnings {
1254 my ($from, $to) = @_;
1255 if (($to & WARN_MASK) eq warnings::bits("all")) {
1256 return "use warnings;\n";
1258 elsif (($to & WARN_MASK) eq "\0"x length($to)) {
1259 return "no warnings;\n";
1261 return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n";
1265 my ($from, $to) = @_;
1266 my $use = $to & ~$from;
1267 my $no = $from & ~$to;
1269 for my $pragma (hint_pragmas($use)) {
1270 $decls .= "use $pragma;\n";
1272 for my $pragma (hint_pragmas($no)) {
1273 $decls .= "no $pragma;\n";
1281 push @pragmas, "integer" if $bits & 0x1;
1282 push @pragmas, "strict 'refs'" if $bits & 0x2;
1283 push @pragmas, "bytes" if $bits & 0x8;
1287 sub pp_dbstate { pp_nextstate(@_) }
1288 sub pp_setstate { pp_nextstate(@_) }
1290 sub pp_unstack { return "" } # see also leaveloop
1294 my($op, $cx, $name) = @_;
1300 my($op, $cx, $name) = @_;
1308 sub pp_wantarray { baseop(@_, "wantarray") }
1309 sub pp_fork { baseop(@_, "fork") }
1310 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1311 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1312 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1313 sub pp_tms { baseop(@_, "times") }
1314 sub pp_ghostent { baseop(@_, "gethostent") }
1315 sub pp_gnetent { baseop(@_, "getnetent") }
1316 sub pp_gprotoent { baseop(@_, "getprotoent") }
1317 sub pp_gservent { baseop(@_, "getservent") }
1318 sub pp_ehostent { baseop(@_, "endhostent") }
1319 sub pp_enetent { baseop(@_, "endnetent") }
1320 sub pp_eprotoent { baseop(@_, "endprotoent") }
1321 sub pp_eservent { baseop(@_, "endservent") }
1322 sub pp_gpwent { baseop(@_, "getpwent") }
1323 sub pp_spwent { baseop(@_, "setpwent") }
1324 sub pp_epwent { baseop(@_, "endpwent") }
1325 sub pp_ggrent { baseop(@_, "getgrent") }
1326 sub pp_sgrent { baseop(@_, "setgrent") }
1327 sub pp_egrent { baseop(@_, "endgrent") }
1328 sub pp_getlogin { baseop(@_, "getlogin") }
1330 sub POSTFIX () { 1 }
1332 # I couldn't think of a good short name, but this is the category of
1333 # symbolic unary operators with interesting precedence
1337 my($op, $cx, $name, $prec, $flags) = (@_, 0);
1338 my $kid = $op->first;
1339 $kid = $self->deparse($kid, $prec);
1340 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1344 sub pp_preinc { pfixop(@_, "++", 23) }
1345 sub pp_predec { pfixop(@_, "--", 23) }
1346 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1347 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1348 sub pp_i_preinc { pfixop(@_, "++", 23) }
1349 sub pp_i_predec { pfixop(@_, "--", 23) }
1350 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1351 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1352 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1354 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1358 if ($op->first->name =~ /^(i_)?negate$/) {
1360 $self->pfixop($op, $cx, "-", 21.5);
1362 $self->pfixop($op, $cx, "-", 21);
1365 sub pp_i_negate { pp_negate(@_) }
1371 $self->pfixop($op, $cx, "not ", 4);
1373 $self->pfixop($op, $cx, "!", 21);
1379 my($op, $cx, $name) = @_;
1381 if ($op->flags & OPf_KIDS) {
1383 if (defined prototype("CORE::$name")
1384 && prototype("CORE::$name") =~ /^;?\*/
1385 && $kid->name eq "rv2gv") {
1389 return $self->maybe_parens_unop($name, $kid, $cx);
1391 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1395 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1396 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1397 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1398 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1399 sub pp_defined { unop(@_, "defined") }
1400 sub pp_undef { unop(@_, "undef") }
1401 sub pp_study { unop(@_, "study") }
1402 sub pp_ref { unop(@_, "ref") }
1403 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1405 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1406 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1407 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1408 sub pp_srand { unop(@_, "srand") }
1409 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1410 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1411 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1412 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1413 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1414 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1415 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1417 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1418 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1419 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1421 sub pp_each { unop(@_, "each") }
1422 sub pp_values { unop(@_, "values") }
1423 sub pp_keys { unop(@_, "keys") }
1424 sub pp_pop { unop(@_, "pop") }
1425 sub pp_shift { unop(@_, "shift") }
1427 sub pp_caller { unop(@_, "caller") }
1428 sub pp_reset { unop(@_, "reset") }
1429 sub pp_exit { unop(@_, "exit") }
1430 sub pp_prototype { unop(@_, "prototype") }
1432 sub pp_close { unop(@_, "close") }
1433 sub pp_fileno { unop(@_, "fileno") }
1434 sub pp_umask { unop(@_, "umask") }
1435 sub pp_untie { unop(@_, "untie") }
1436 sub pp_tied { unop(@_, "tied") }
1437 sub pp_dbmclose { unop(@_, "dbmclose") }
1438 sub pp_getc { unop(@_, "getc") }
1439 sub pp_eof { unop(@_, "eof") }
1440 sub pp_tell { unop(@_, "tell") }
1441 sub pp_getsockname { unop(@_, "getsockname") }
1442 sub pp_getpeername { unop(@_, "getpeername") }
1444 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1445 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1446 sub pp_readlink { unop(@_, "readlink") }
1447 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1448 sub pp_readdir { unop(@_, "readdir") }
1449 sub pp_telldir { unop(@_, "telldir") }
1450 sub pp_rewinddir { unop(@_, "rewinddir") }
1451 sub pp_closedir { unop(@_, "closedir") }
1452 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1453 sub pp_localtime { unop(@_, "localtime") }
1454 sub pp_gmtime { unop(@_, "gmtime") }
1455 sub pp_alarm { unop(@_, "alarm") }
1456 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1458 sub pp_dofile { unop(@_, "do") }
1459 sub pp_entereval { unop(@_, "eval") }
1461 sub pp_ghbyname { unop(@_, "gethostbyname") }
1462 sub pp_gnbyname { unop(@_, "getnetbyname") }
1463 sub pp_gpbyname { unop(@_, "getprotobyname") }
1464 sub pp_shostent { unop(@_, "sethostent") }
1465 sub pp_snetent { unop(@_, "setnetent") }
1466 sub pp_sprotoent { unop(@_, "setprotoent") }
1467 sub pp_sservent { unop(@_, "setservent") }
1468 sub pp_gpwnam { unop(@_, "getpwnam") }
1469 sub pp_gpwuid { unop(@_, "getpwuid") }
1470 sub pp_ggrnam { unop(@_, "getgrnam") }
1471 sub pp_ggrgid { unop(@_, "getgrgid") }
1473 sub pp_lock { unop(@_, "lock") }
1479 if ($op->private & OPpEXISTS_SUB) {
1480 # Checking for the existence of a subroutine
1481 return $self->maybe_parens_func("exists",
1482 $self->pp_rv2cv($op->first, 16), $cx, 16);
1484 if ($op->flags & OPf_SPECIAL) {
1485 # Array element, not hash element
1486 return $self->maybe_parens_func("exists",
1487 $self->pp_aelem($op->first, 16), $cx, 16);
1489 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1497 if ($op->private & OPpSLICE) {
1498 if ($op->flags & OPf_SPECIAL) {
1499 # Deleting from an array, not a hash
1500 return $self->maybe_parens_func("delete",
1501 $self->pp_aslice($op->first, 16),
1504 return $self->maybe_parens_func("delete",
1505 $self->pp_hslice($op->first, 16),
1508 if ($op->flags & OPf_SPECIAL) {
1509 # Deleting from an array, not a hash
1510 return $self->maybe_parens_func("delete",
1511 $self->pp_aelem($op->first, 16),
1514 return $self->maybe_parens_func("delete",
1515 $self->pp_helem($op->first, 16),
1523 if (class($op) eq "UNOP" and $op->first->name eq "const"
1524 and $op->first->private & OPpCONST_BARE)
1526 my $name = $self->const_sv($op->first)->PV;
1529 return "require $name";
1531 $self->unop($op, $cx, "require");
1538 my $kid = $op->first;
1539 if (not null $kid->sibling) {
1540 # XXX Was a here-doc
1541 return $self->dquote($op);
1543 $self->unop(@_, "scalar");
1550 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1556 my $kid = $op->first;
1557 if ($kid->name eq "null") {
1559 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1560 my($pre, $post) = @{{"anonlist" => ["[","]"],
1561 "anonhash" => ["{","}"]}->{$kid->name}};
1563 $kid = $kid->first->sibling; # skip pushmark
1564 for (; !null($kid); $kid = $kid->sibling) {
1565 $expr = $self->deparse($kid, 6);
1568 return $pre . join(", ", @exprs) . $post;
1569 } elsif (!null($kid->sibling) and
1570 $kid->sibling->name eq "anoncode") {
1572 $self->deparse_sub($self->padval($kid->sibling->targ));
1573 } elsif ($kid->name eq "pushmark") {
1574 my $sib_name = $kid->sibling->name;
1575 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1576 and not $kid->sibling->flags & OPf_REF)
1578 # The @a in \(@a) isn't in ref context, but only when the
1580 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1581 } elsif ($sib_name eq 'entersub') {
1582 my $text = $self->deparse($kid->sibling, 1);
1583 # Always show parens for \(&func()), but only with -p otherwise
1584 $text = "($text)" if $self->{'parens'}
1585 or $kid->sibling->private & OPpENTERSUB_AMPER;
1590 $self->pfixop($op, $cx, "\\", 20);
1593 sub pp_srefgen { pp_refgen(@_) }
1598 my $kid = $op->first;
1599 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1600 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
1601 return $self->unop($op, $cx, "readline");
1607 return "<" . $self->gv_name($op->gv) . ">";
1610 # Unary operators that can occur as pseudo-listops inside double quotes
1613 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1615 if ($op->flags & OPf_KIDS) {
1617 # If there's more than one kid, the first is an ex-pushmark.
1618 $kid = $kid->sibling if not null $kid->sibling;
1619 return $self->maybe_parens_unop($name, $kid, $cx);
1621 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1625 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1626 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1627 sub pp_uc { dq_unop(@_, "uc") }
1628 sub pp_lc { dq_unop(@_, "lc") }
1629 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1633 my ($op, $cx, $name) = @_;
1634 if (class($op) eq "PVOP") {
1635 return "$name " . $op->pv;
1636 } elsif (class($op) eq "OP") {
1638 } elsif (class($op) eq "UNOP") {
1639 # Note -- loop exits are actually exempt from the
1640 # looks-like-a-func rule, but a few extra parens won't hurt
1641 return $self->maybe_parens_unop($name, $op->first, $cx);
1645 sub pp_last { loopex(@_, "last") }
1646 sub pp_next { loopex(@_, "next") }
1647 sub pp_redo { loopex(@_, "redo") }
1648 sub pp_goto { loopex(@_, "goto") }
1649 sub pp_dump { loopex(@_, "dump") }
1653 my($op, $cx, $name) = @_;
1654 if (class($op) eq "UNOP") {
1655 # Genuine `-X' filetests are exempt from the LLAFR, but not
1656 # l?stat(); for the sake of clarity, give'em all parens
1657 return $self->maybe_parens_unop($name, $op->first, $cx);
1658 } elsif (class($op) eq "SVOP") {
1659 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1660 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1665 sub pp_lstat { ftst(@_, "lstat") }
1666 sub pp_stat { ftst(@_, "stat") }
1667 sub pp_ftrread { ftst(@_, "-R") }
1668 sub pp_ftrwrite { ftst(@_, "-W") }
1669 sub pp_ftrexec { ftst(@_, "-X") }
1670 sub pp_fteread { ftst(@_, "-r") }
1671 sub pp_ftewrite { ftst(@_, "-w") }
1672 sub pp_fteexec { ftst(@_, "-x") }
1673 sub pp_ftis { ftst(@_, "-e") }
1674 sub pp_fteowned { ftst(@_, "-O") }
1675 sub pp_ftrowned { ftst(@_, "-o") }
1676 sub pp_ftzero { ftst(@_, "-z") }
1677 sub pp_ftsize { ftst(@_, "-s") }
1678 sub pp_ftmtime { ftst(@_, "-M") }
1679 sub pp_ftatime { ftst(@_, "-A") }
1680 sub pp_ftctime { ftst(@_, "-C") }
1681 sub pp_ftsock { ftst(@_, "-S") }
1682 sub pp_ftchr { ftst(@_, "-c") }
1683 sub pp_ftblk { ftst(@_, "-b") }
1684 sub pp_ftfile { ftst(@_, "-f") }
1685 sub pp_ftdir { ftst(@_, "-d") }
1686 sub pp_ftpipe { ftst(@_, "-p") }
1687 sub pp_ftlink { ftst(@_, "-l") }
1688 sub pp_ftsuid { ftst(@_, "-u") }
1689 sub pp_ftsgid { ftst(@_, "-g") }
1690 sub pp_ftsvtx { ftst(@_, "-k") }
1691 sub pp_fttty { ftst(@_, "-t") }
1692 sub pp_fttext { ftst(@_, "-T") }
1693 sub pp_ftbinary { ftst(@_, "-B") }
1695 sub SWAP_CHILDREN () { 1 }
1696 sub ASSIGN () { 2 } # has OP= variant
1697 sub LIST_CONTEXT () { 4 } # Assignment is in list context
1703 my $name = $op->name;
1704 if ($name eq "concat" and $op->first->name eq "concat") {
1705 # avoid spurious `=' -- see comment in pp_concat
1708 if ($name eq "null" and class($op) eq "UNOP"
1709 and $op->first->name =~ /^(and|x?or)$/
1710 and null $op->first->sibling)
1712 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1713 # with a null that's used as the common end point of the two
1714 # flows of control. For precedence purposes, ignore it.
1715 # (COND_EXPRs have these too, but we don't bother with
1716 # their associativity).
1717 return assoc_class($op->first);
1719 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1722 # Left associative operators, like `+', for which
1723 # $a + $b + $c is equivalent to ($a + $b) + $c
1726 %left = ('multiply' => 19, 'i_multiply' => 19,
1727 'divide' => 19, 'i_divide' => 19,
1728 'modulo' => 19, 'i_modulo' => 19,
1730 'add' => 18, 'i_add' => 18,
1731 'subtract' => 18, 'i_subtract' => 18,
1733 'left_shift' => 17, 'right_shift' => 17,
1735 'bit_or' => 12, 'bit_xor' => 12,
1737 'or' => 2, 'xor' => 2,
1741 sub deparse_binop_left {
1743 my($op, $left, $prec) = @_;
1744 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1745 and $left{assoc_class($op)} == $left{assoc_class($left)})
1747 return $self->deparse($left, $prec - .00001);
1749 return $self->deparse($left, $prec);
1753 # Right associative operators, like `=', for which
1754 # $a = $b = $c is equivalent to $a = ($b = $c)
1757 %right = ('pow' => 22,
1758 'sassign=' => 7, 'aassign=' => 7,
1759 'multiply=' => 7, 'i_multiply=' => 7,
1760 'divide=' => 7, 'i_divide=' => 7,
1761 'modulo=' => 7, 'i_modulo=' => 7,
1763 'add=' => 7, 'i_add=' => 7,
1764 'subtract=' => 7, 'i_subtract=' => 7,
1766 'left_shift=' => 7, 'right_shift=' => 7,
1768 'bit_or=' => 7, 'bit_xor=' => 7,
1774 sub deparse_binop_right {
1776 my($op, $right, $prec) = @_;
1777 if ($right{assoc_class($op)} && $right{assoc_class($right)}
1778 and $right{assoc_class($op)} == $right{assoc_class($right)})
1780 return $self->deparse($right, $prec - .00001);
1782 return $self->deparse($right, $prec);
1788 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1789 my $left = $op->first;
1790 my $right = $op->last;
1792 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1796 if ($flags & SWAP_CHILDREN) {
1797 ($left, $right) = ($right, $left);
1799 $left = $self->deparse_binop_left($op, $left, $prec);
1800 $left = "($left)" if $flags & LIST_CONTEXT
1801 && $left !~ /^(my|our|local|)[\@\(]/;
1802 $right = $self->deparse_binop_right($op, $right, $prec);
1803 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1806 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1807 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1808 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1809 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1810 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1811 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1812 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1813 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1814 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1815 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1816 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1818 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1819 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1820 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1821 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1822 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1824 sub pp_eq { binop(@_, "==", 14) }
1825 sub pp_ne { binop(@_, "!=", 14) }
1826 sub pp_lt { binop(@_, "<", 15) }
1827 sub pp_gt { binop(@_, ">", 15) }
1828 sub pp_ge { binop(@_, ">=", 15) }
1829 sub pp_le { binop(@_, "<=", 15) }
1830 sub pp_ncmp { binop(@_, "<=>", 14) }
1831 sub pp_i_eq { binop(@_, "==", 14) }
1832 sub pp_i_ne { binop(@_, "!=", 14) }
1833 sub pp_i_lt { binop(@_, "<", 15) }
1834 sub pp_i_gt { binop(@_, ">", 15) }
1835 sub pp_i_ge { binop(@_, ">=", 15) }
1836 sub pp_i_le { binop(@_, "<=", 15) }
1837 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1839 sub pp_seq { binop(@_, "eq", 14) }
1840 sub pp_sne { binop(@_, "ne", 14) }
1841 sub pp_slt { binop(@_, "lt", 15) }
1842 sub pp_sgt { binop(@_, "gt", 15) }
1843 sub pp_sge { binop(@_, "ge", 15) }
1844 sub pp_sle { binop(@_, "le", 15) }
1845 sub pp_scmp { binop(@_, "cmp", 14) }
1847 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1848 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
1850 # `.' is special because concats-of-concats are optimized to save copying
1851 # by making all but the first concat stacked. The effect is as if the
1852 # programmer had written `($a . $b) .= $c', except legal.
1853 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1857 my $left = $op->first;
1858 my $right = $op->last;
1861 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1865 $left = $self->deparse_binop_left($op, $left, $prec);
1866 $right = $self->deparse_binop_right($op, $right, $prec);
1867 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1870 # `x' is weird when the left arg is a list
1874 my $left = $op->first;
1875 my $right = $op->last;
1878 if ($op->flags & OPf_STACKED) {
1882 if (null($right)) { # list repeat; count is inside left-side ex-list
1883 my $kid = $left->first->sibling; # skip pushmark
1885 for (; !null($kid->sibling); $kid = $kid->sibling) {
1886 push @exprs, $self->deparse($kid, 6);
1889 $left = "(" . join(", ", @exprs). ")";
1891 $left = $self->deparse_binop_left($op, $left, $prec);
1893 $right = $self->deparse_binop_right($op, $right, $prec);
1894 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1899 my ($op, $cx, $type) = @_;
1900 my $left = $op->first;
1901 my $right = $left->sibling;
1902 $left = $self->deparse($left, 9);
1903 $right = $self->deparse($right, 9);
1904 return $self->maybe_parens("$left $type $right", $cx, 9);
1910 my $flip = $op->first;
1911 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1912 return $self->range($flip->first, $cx, $type);
1915 # one-line while/until is handled in pp_leave
1919 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1920 my $left = $op->first;
1921 my $right = $op->first->sibling;
1922 if ($cx == 0 and is_scope($right) and $blockname
1923 and $self->{'expand'} < 7)
1925 $left = $self->deparse($left, 1);
1926 $right = $self->deparse($right, 0);
1927 return "$blockname ($left) {\n\t$right\n\b}\cK";
1928 } elsif ($cx == 0 and $blockname and not $self->{'parens'}
1929 and $self->{'expand'} < 7) { # $b if $a
1930 $right = $self->deparse($right, 1);
1931 $left = $self->deparse($left, 1);
1932 return "$right $blockname $left";
1933 } elsif ($cx > $lowprec and $highop) { # $a && $b
1934 $left = $self->deparse_binop_left($op, $left, $highprec);
1935 $right = $self->deparse_binop_right($op, $right, $highprec);
1936 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1937 } else { # $a and $b
1938 $left = $self->deparse_binop_left($op, $left, $lowprec);
1939 $right = $self->deparse_binop_right($op, $right, $lowprec);
1940 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1944 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1945 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1947 # xor is syntactically a logop, but it's really a binop (contrary to
1948 # old versions of opcode.pl). Syntax is what matters here.
1949 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1953 my ($op, $cx, $opname) = @_;
1954 my $left = $op->first;
1955 my $right = $op->first->sibling->first; # skip sassign
1956 $left = $self->deparse($left, 7);
1957 $right = $self->deparse($right, 7);
1958 return $self->maybe_parens("$left $opname $right", $cx, 7);
1961 sub pp_andassign { logassignop(@_, "&&=") }
1962 sub pp_orassign { logassignop(@_, "||=") }
1966 my($op, $cx, $name) = @_;
1968 my $parens = ($cx >= 5) || $self->{'parens'};
1969 my $kid = $op->first->sibling;
1970 return $name if null $kid;
1972 if (defined prototype("CORE::$name")
1973 && prototype("CORE::$name") =~ /^;?\*/
1974 && $kid->name eq "rv2gv") {
1975 $first = $self->deparse($kid->first, 6);
1978 $first = $self->deparse($kid, 6);
1980 if ($name eq "chmod" && $first =~ /^\d+$/) {
1981 $first = sprintf("%#o", $first);
1983 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1984 push @exprs, $first;
1985 $kid = $kid->sibling;
1986 for (; !null($kid); $kid = $kid->sibling) {
1987 push @exprs, $self->deparse($kid, 6);
1990 return "$name(" . join(", ", @exprs) . ")";
1992 return "$name " . join(", ", @exprs);
1996 sub pp_bless { listop(@_, "bless") }
1997 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
1998 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1999 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
2000 sub pp_index { maybe_targmy(@_, \&listop, "index") }
2001 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
2002 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
2003 sub pp_formline { listop(@_, "formline") } # see also deparse_format
2004 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
2005 sub pp_unpack { listop(@_, "unpack") }
2006 sub pp_pack { listop(@_, "pack") }
2007 sub pp_join { maybe_targmy(@_, \&listop, "join") }
2008 sub pp_splice { listop(@_, "splice") }
2009 sub pp_push { maybe_targmy(@_, \&listop, "push") }
2010 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
2011 sub pp_reverse { listop(@_, "reverse") }
2012 sub pp_warn { listop(@_, "warn") }
2013 sub pp_die { listop(@_, "die") }
2014 # Actually, return is exempt from the LLAFR (see examples in this very
2015 # module!), but for consistency's sake, ignore that fact
2016 sub pp_return { listop(@_, "return") }
2017 sub pp_open { listop(@_, "open") }
2018 sub pp_pipe_op { listop(@_, "pipe") }
2019 sub pp_tie { listop(@_, "tie") }
2020 sub pp_binmode { listop(@_, "binmode") }
2021 sub pp_dbmopen { listop(@_, "dbmopen") }
2022 sub pp_sselect { listop(@_, "select") }
2023 sub pp_select { listop(@_, "select") }
2024 sub pp_read { listop(@_, "read") }
2025 sub pp_sysopen { listop(@_, "sysopen") }
2026 sub pp_sysseek { listop(@_, "sysseek") }
2027 sub pp_sysread { listop(@_, "sysread") }
2028 sub pp_syswrite { listop(@_, "syswrite") }
2029 sub pp_send { listop(@_, "send") }
2030 sub pp_recv { listop(@_, "recv") }
2031 sub pp_seek { listop(@_, "seek") }
2032 sub pp_fcntl { listop(@_, "fcntl") }
2033 sub pp_ioctl { listop(@_, "ioctl") }
2034 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
2035 sub pp_socket { listop(@_, "socket") }
2036 sub pp_sockpair { listop(@_, "sockpair") }
2037 sub pp_bind { listop(@_, "bind") }
2038 sub pp_connect { listop(@_, "connect") }
2039 sub pp_listen { listop(@_, "listen") }
2040 sub pp_accept { listop(@_, "accept") }
2041 sub pp_shutdown { listop(@_, "shutdown") }
2042 sub pp_gsockopt { listop(@_, "getsockopt") }
2043 sub pp_ssockopt { listop(@_, "setsockopt") }
2044 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
2045 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
2046 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
2047 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
2048 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
2049 sub pp_link { maybe_targmy(@_, \&listop, "link") }
2050 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
2051 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
2052 sub pp_open_dir { listop(@_, "opendir") }
2053 sub pp_seekdir { listop(@_, "seekdir") }
2054 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
2055 sub pp_system { maybe_targmy(@_, \&listop, "system") }
2056 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
2057 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
2058 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
2059 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
2060 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
2061 sub pp_shmget { listop(@_, "shmget") }
2062 sub pp_shmctl { listop(@_, "shmctl") }
2063 sub pp_shmread { listop(@_, "shmread") }
2064 sub pp_shmwrite { listop(@_, "shmwrite") }
2065 sub pp_msgget { listop(@_, "msgget") }
2066 sub pp_msgctl { listop(@_, "msgctl") }
2067 sub pp_msgsnd { listop(@_, "msgsnd") }
2068 sub pp_msgrcv { listop(@_, "msgrcv") }
2069 sub pp_semget { listop(@_, "semget") }
2070 sub pp_semctl { listop(@_, "semctl") }
2071 sub pp_semop { listop(@_, "semop") }
2072 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
2073 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
2074 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
2075 sub pp_gsbyname { listop(@_, "getservbyname") }
2076 sub pp_gsbyport { listop(@_, "getservbyport") }
2077 sub pp_syscall { listop(@_, "syscall") }
2082 my $text = $self->dq($op->first->sibling); # skip pushmark
2083 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
2084 or $text =~ /[<>]/) {
2085 return 'glob(' . single_delim('qq', '"', $text) . ')';
2087 return '<' . $text . '>';
2091 # Truncate is special because OPf_SPECIAL makes a bareword first arg
2092 # be a filehandle. This could probably be better fixed in the core
2093 # by moving the GV lookup into ck_truc.
2099 my $parens = ($cx >= 5) || $self->{'parens'};
2100 my $kid = $op->first->sibling;
2102 if ($op->flags & OPf_SPECIAL) {
2103 # $kid is an OP_CONST
2104 $fh = $self->const_sv($kid)->PV;
2106 $fh = $self->deparse($kid, 6);
2107 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
2109 my $len = $self->deparse($kid->sibling, 6);
2111 return "truncate($fh, $len)";
2113 return "truncate $fh, $len";
2119 my($op, $cx, $name) = @_;
2121 my $kid = $op->first->sibling;
2123 if ($op->flags & OPf_STACKED) {
2125 $indir = $indir->first; # skip rv2gv
2126 if (is_scope($indir)) {
2127 $indir = "{" . $self->deparse($indir, 0) . "}";
2128 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
2129 $indir = $self->const_sv($indir)->PV;
2131 $indir = $self->deparse($indir, 24);
2133 $indir = $indir . " ";
2134 $kid = $kid->sibling;
2136 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
2137 $indir = ($op->private & OPpSORT_REVERSE) ? '{$b <=> $a} '
2140 elsif ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
2141 $indir = '{$b cmp $a} ';
2143 for (; !null($kid); $kid = $kid->sibling) {
2144 $expr = $self->deparse($kid, 6);
2147 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
2151 sub pp_prtf { indirop(@_, "printf") }
2152 sub pp_print { indirop(@_, "print") }
2153 sub pp_sort { indirop(@_, "sort") }
2157 my($op, $cx, $name) = @_;
2159 my $kid = $op->first; # this is the (map|grep)start
2160 $kid = $kid->first->sibling; # skip a pushmark
2161 my $code = $kid->first; # skip a null
2162 if (is_scope $code) {
2163 $code = "{" . $self->deparse($code, 0) . "} ";
2165 $code = $self->deparse($code, 24) . ", ";
2167 $kid = $kid->sibling;
2168 for (; !null($kid); $kid = $kid->sibling) {
2169 $expr = $self->deparse($kid, 6);
2170 push @exprs, $expr if $expr;
2172 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2175 sub pp_mapwhile { mapop(@_, "map") }
2176 sub pp_grepwhile { mapop(@_, "grep") }
2182 my $kid = $op->first->sibling; # skip pushmark
2184 my $local = "either"; # could be local(...), my(...) or our(...)
2185 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2186 # This assumes that no other private flags equal 128, and that
2187 # OPs that store things other than flags in their op_private,
2188 # like OP_AELEMFAST, won't be immediate children of a list.
2190 # OP_ENTERSUB can break this logic, so check for it.
2191 # I suspect that open and exit can too.
2193 if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
2194 or $lop->name eq "undef")
2195 or $lop->name eq "entersub"
2196 or $lop->name eq "exit"
2197 or $lop->name eq "open")
2199 $local = ""; # or not
2202 if ($lop->name =~ /^pad[ash]v$/) { # my()
2203 ($local = "", last) if $local eq "local" || $local eq "our";
2205 } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
2206 && $lop->private & OPpOUR_INTRO
2207 or $lop->name eq "null" && $lop->first->name eq "gvsv"
2208 && $lop->first->private & OPpOUR_INTRO) { # our()
2209 ($local = "", last) if $local eq "my" || $local eq "local";
2211 } elsif ($lop->name ne "undef") { # local()
2212 ($local = "", last) if $local eq "my" || $local eq "our";
2216 $local = "" if $local eq "either"; # no point if it's all undefs
2217 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2218 for (; !null($kid); $kid = $kid->sibling) {
2220 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2225 $self->{'avoid_local'}{$$lop}++;
2226 $expr = $self->deparse($kid, 6);
2227 delete $self->{'avoid_local'}{$$lop};
2229 $expr = $self->deparse($kid, 6);
2234 return "$local(" . join(", ", @exprs) . ")";
2236 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2240 sub is_ifelse_cont {
2242 return ($op->name eq "null" and class($op) eq "UNOP"
2243 and $op->first->name =~ /^(and|cond_expr)$/
2244 and is_scope($op->first->first->sibling));
2250 my $cond = $op->first;
2251 my $true = $cond->sibling;
2252 my $false = $true->sibling;
2253 my $cuddle = $self->{'cuddle'};
2254 unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
2255 (is_scope($false) || is_ifelse_cont($false))
2256 and $self->{'expand'} < 7) {
2257 $cond = $self->deparse($cond, 8);
2258 $true = $self->deparse($true, 8);
2259 $false = $self->deparse($false, 8);
2260 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2263 $cond = $self->deparse($cond, 1);
2264 $true = $self->deparse($true, 0);
2265 my $head = "if ($cond) {\n\t$true\n\b}";
2267 while (!null($false) and is_ifelse_cont($false)) {
2268 my $newop = $false->first;
2269 my $newcond = $newop->first;
2270 my $newtrue = $newcond->sibling;
2271 $false = $newtrue->sibling; # last in chain is OP_AND => no else
2272 $newcond = $self->deparse($newcond, 1);
2273 $newtrue = $self->deparse($newtrue, 0);
2274 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2276 if (!null($false)) {
2277 $false = $cuddle . "else {\n\t" .
2278 $self->deparse($false, 0) . "\n\b}\cK";
2282 return $head . join($cuddle, "", @elsifs) . $false;
2287 my($op, $cx, $init) = @_;
2288 my $enter = $op->first;
2289 my $kid = $enter->sibling;
2290 local(@$self{qw'curstash warnings hints'})
2291 = @$self{qw'curstash warnings hints'};
2296 if ($kid->name eq "lineseq") { # bare or infinite loop
2297 if (is_state $kid->last) { # infinite
2298 $head = "while (1) "; # Can't use for(;;) if there's a continue
2304 } elsif ($enter->name eq "enteriter") { # foreach
2305 my $ary = $enter->first->sibling; # first was pushmark
2306 my $var = $ary->sibling;
2307 if ($enter->flags & OPf_STACKED
2308 and not null $ary->first->sibling->sibling)
2310 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2311 $self->deparse($ary->first->sibling->sibling, 9);
2313 $ary = $self->deparse($ary, 1);
2316 if ($enter->flags & OPf_SPECIAL) { # thread special var
2317 $var = $self->pp_threadsv($enter, 1);
2318 } else { # regular my() variable
2319 $var = $self->pp_padsv($enter, 1);
2320 if ($self->padname_sv($enter->targ)->IVX ==
2321 $kid->first->first->sibling->last->cop_seq)
2323 # If the scope of this variable closes at the last
2324 # statement of the loop, it must have been
2326 $var = "my " . $var;
2329 } elsif ($var->name eq "rv2gv") {
2330 $var = $self->pp_rv2sv($var, 1);
2331 } elsif ($var->name eq "gv") {
2332 $var = "\$" . $self->deparse($var, 1);
2334 $head = "foreach $var ($ary) ";
2335 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2336 } elsif ($kid->name eq "null") { # while/until
2338 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2339 $cond = $self->deparse($kid->first, 1);
2340 $head = "$name ($cond) ";
2341 $body = $kid->first->sibling;
2342 } elsif ($kid->name eq "stub") { # bare and empty
2343 return "{;}"; # {} could be a hashref
2345 # If there isn't a continue block, then the next pointer for the loop
2346 # will point to the unstack, which is kid's penultimate child, except
2347 # in a bare loop, when it will point to the leaveloop. When neither of
2348 # these conditions hold, then the third-to-last child in the continue
2349 # block (or the last in a bare loop).
2350 my $cont_start = $enter->nextop;
2352 if ($$cont_start != $$op && ${$cont_start->sibling} != ${$body->last}) {
2354 $cont = $body->last;
2356 $cont = $body->first;
2357 while (!null($cont->sibling->sibling->sibling)) {
2358 $cont = $cont->sibling;
2361 my $state = $body->first;
2362 my $cuddle = $self->{'cuddle'};
2364 for (; $$state != $$cont; $state = $state->sibling) {
2365 push @states, $state;
2367 $body = $self->lineseq(undef, @states);
2368 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2369 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2372 $cont = $cuddle . "continue {\n\t" .
2373 $self->deparse($cont, 0) . "\n\b}\cK";
2376 return "" if !defined $body;
2378 $head = "for ($init; $cond;) ";
2381 $body = $self->deparse($body, 0);
2383 $body =~ s/;?$/;\n/;
2385 return $head . "{\n\t" . $body . "\b}" . $cont;
2388 sub pp_leaveloop { loop_common(@_, "") }
2393 my $init = $self->deparse($op, 1);
2394 return $self->loop_common($op->sibling->first->sibling, $cx, $init);
2399 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2402 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2403 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2404 BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
2405 BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
2410 if (class($op) eq "OP") {
2412 return $self->{'ex_const'} if $op->targ == OP_CONST;
2413 } elsif ($op->first->name eq "pushmark") {
2414 return $self->pp_list($op, $cx);
2415 } elsif ($op->first->name eq "enter") {
2416 return $self->pp_leave($op, $cx);
2417 } elsif ($op->targ == OP_STRINGIFY) {
2418 return $self->dquote($op, $cx);
2419 } elsif (!null($op->first->sibling) and
2420 $op->first->sibling->name eq "readline" and
2421 $op->first->sibling->flags & OPf_STACKED) {
2422 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2423 . $self->deparse($op->first->sibling, 7),
2425 } elsif (!null($op->first->sibling) and
2426 $op->first->sibling->name eq "trans" and
2427 $op->first->sibling->flags & OPf_STACKED) {
2428 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2429 . $self->deparse($op->first->sibling, 20),
2431 } elsif ($op->flags & OPf_SPECIAL && $cx == 0 && !$op->targ) {
2432 return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
2433 } elsif (!null($op->first->sibling) and
2434 $op->first->sibling->name eq "null" and
2435 class($op->first->sibling) eq "UNOP" and
2436 $op->first->sibling->first->flags & OPf_STACKED and
2437 $op->first->sibling->first->name eq "rcatline") {
2438 return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
2439 . $self->deparse($op->first->sibling, 18),
2442 return $self->deparse($op->first, $cx);
2449 return $self->padname_sv($targ)->PVX;
2455 return substr($self->padname($op->targ), 1); # skip $/@/%
2461 return $self->maybe_my($op, $cx, $self->padname($op->targ));
2464 sub pp_padav { pp_padsv(@_) }
2465 sub pp_padhv { pp_padsv(@_) }
2470 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2471 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2472 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2479 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
2485 if (class($op) eq "PADOP") {
2486 return $self->padval($op->padix);
2487 } else { # class($op) eq "SVOP"
2495 my $gv = $self->gv_or_padgv($op);
2496 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2497 $self->gv_name($gv)));
2503 my $gv = $self->gv_or_padgv($op);
2504 return $self->gv_name($gv);
2510 my $gv = $self->gv_or_padgv($op);
2511 my $name = $self->gv_name($gv);
2512 $name = $self->{'curstash'}."::$name"
2513 if $name !~ /::/ && $self->lex_in_scope('@'.$name);
2515 return "\$" . $name . "[" .
2516 ($op->private + $self->{'arybase'}) . "]";
2521 my($op, $cx, $type) = @_;
2523 if (class($op) eq 'NULL' || !$op->can("first")) {
2524 carp("Unexpected op in pp_rv2x");
2527 my $kid = $op->first;
2528 my $str = $self->deparse($kid, 0);
2529 return $self->stash_variable($type, $str) if is_scalar($kid);
2530 return $type ."{$str}";
2533 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2534 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2535 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2541 if ($op->first->name eq "padav") {
2542 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2544 return $self->maybe_local($op, $cx,
2545 $self->rv2x($op->first, $cx, '$#'));
2549 # skip down to the old, ex-rv2cv
2551 my ($self, $op, $cx) = @_;
2552 if (!null($op->first) && $op->first->name eq 'null' &&
2553 $op->first->targ eq OP_LIST)
2555 return $self->rv2x($op->first->first->sibling, $cx, "&")
2558 return $self->rv2x($op, $cx, "")
2565 my $kid = $op->first;
2566 if ($kid->name eq "const") { # constant list
2567 my $av = $self->const_sv($kid);
2568 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2570 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2574 sub is_subscriptable {
2576 if ($op->name =~ /^[ahg]elem/) {
2578 } elsif ($op->name eq "entersub") {
2579 my $kid = $op->first;
2580 return 0 unless null $kid->sibling;
2582 $kid = $kid->sibling until null $kid->sibling;
2583 return 0 if is_scope($kid);
2585 return 0 if $kid->name eq "gv";
2586 return 0 if is_scalar($kid);
2587 return is_subscriptable($kid);
2595 my ($op, $cx, $left, $right, $padname) = @_;
2596 my($array, $idx) = ($op->first, $op->first->sibling);
2597 unless ($array->name eq $padname) { # Maybe this has been fixed
2598 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2600 if ($array->name eq $padname) {
2601 $array = $self->padany($array);
2602 } elsif (is_scope($array)) { # ${expr}[0]
2603 $array = "{" . $self->deparse($array, 0) . "}";
2604 } elsif ($array->name eq "gv") {
2605 $array = $self->gv_name($self->gv_or_padgv($array));
2606 if ($array !~ /::/) {
2607 my $prefix = ($left eq '[' ? '@' : '%');
2608 $array = $self->{curstash}.'::'.$array
2609 if $self->lex_in_scope($prefix . $array);
2611 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2612 $array = $self->deparse($array, 24);
2614 # $x[20][3]{hi} or expr->[20]
2615 my $arrow = is_subscriptable($array) ? "" : "->";
2616 return $self->deparse($array, 24) . $arrow .
2617 $left . $self->deparse($idx, 1) . $right;
2619 $idx = $self->deparse($idx, 1);
2621 # Outer parens in an array index will confuse perl
2622 # if we're interpolating in a regular expression, i.e.
2623 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2625 # If $self->{parens}, then an initial '(' will
2626 # definitely be paired with a final ')'. If
2627 # !$self->{parens}, the misleading parens won't
2628 # have been added in the first place.
2630 # [You might think that we could get "(...)...(...)"
2631 # where the initial and final parens do not match
2632 # each other. But we can't, because the above would
2633 # only happen if there's an infix binop between the
2634 # two pairs of parens, and *that* means that the whole
2635 # expression would be parenthesized as well.]
2637 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2639 # Hash-element braces will autoquote a bareword inside themselves.
2640 # We need to make sure that C<$hash{warn()}> doesn't come out as
2641 # C<$hash{warn}>, which has a quite different meaning. Currently
2642 # B::Deparse will always quote strings, even if the string was a
2643 # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
2644 # for constant strings.) So we can cheat slightly here - if we see
2645 # a bareword, we know that it is supposed to be a function call.
2647 $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
2649 return "\$" . $array . $left . $idx . $right;
2652 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2653 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2658 my($glob, $part) = ($op->first, $op->last);
2659 $glob = $glob->first; # skip rv2gv
2660 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2661 my $scope = is_scope($glob);
2662 $glob = $self->deparse($glob, 0);
2663 $part = $self->deparse($part, 1);
2664 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2669 my ($op, $cx, $left, $right, $regname, $padname) = @_;
2671 my(@elems, $kid, $array, $list);
2672 if (class($op) eq "LISTOP") {
2674 } else { # ex-hslice inside delete()
2675 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2679 $array = $array->first
2680 if $array->name eq $regname or $array->name eq "null";
2681 if (is_scope($array)) {
2682 $array = "{" . $self->deparse($array, 0) . "}";
2683 } elsif ($array->name eq $padname) {
2684 $array = $self->padany($array);
2686 $array = $self->deparse($array, 24);
2688 $kid = $op->first->sibling; # skip pushmark
2689 if ($kid->name eq "list") {
2690 $kid = $kid->first->sibling; # skip list, pushmark
2691 for (; !null $kid; $kid = $kid->sibling) {
2692 push @elems, $self->deparse($kid, 6);
2694 $list = join(", ", @elems);
2696 $list = $self->deparse($kid, 1);
2698 return "\@" . $array . $left . $list . $right;
2701 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2702 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2707 my $idx = $op->first;
2708 my $list = $op->last;
2710 $list = $self->deparse($list, 1);
2711 $idx = $self->deparse($idx, 1);
2712 return "($list)" . "[$idx]";
2717 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2722 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2728 my $kid = $op->first->sibling; # skip pushmark
2729 my($meth, $obj, @exprs);
2730 if ($kid->name eq "list" and want_list $kid) {
2731 # When an indirect object isn't a bareword but the args are in
2732 # parens, the parens aren't part of the method syntax (the LLAFR
2733 # doesn't apply), but they make a list with OPf_PARENS set that
2734 # doesn't get flattened by the append_elem that adds the method,
2735 # making a (object, arg1, arg2, ...) list where the object
2736 # usually is. This can be distinguished from
2737 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2738 # object) because in the later the list is in scalar context
2739 # as the left side of -> always is, while in the former
2740 # the list is in list context as method arguments always are.
2741 # (Good thing there aren't method prototypes!)
2742 $meth = $kid->sibling;
2743 $kid = $kid->first->sibling; # skip pushmark
2745 $kid = $kid->sibling;
2746 for (; not null $kid; $kid = $kid->sibling) {
2747 push @exprs, $self->deparse($kid, 6);
2751 $kid = $kid->sibling;
2752 for (; !null ($kid->sibling) && $kid->name ne "method_named";
2753 $kid = $kid->sibling) {
2754 push @exprs, $self->deparse($kid, 6);
2758 $obj = $self->deparse($obj, 24);
2759 if ($meth->name eq "method_named") {
2760 $meth = $self->const_sv($meth)->PV;
2762 $meth = $meth->first;
2763 if ($meth->name eq "const") {
2764 # As of 5.005_58, this case is probably obsoleted by the
2765 # method_named case above
2766 $meth = $self->const_sv($meth)->PV; # needs to be bare
2768 $meth = $self->deparse($meth, 1);
2771 my $args = join(", ", @exprs);
2772 $kid = $obj . "->" . $meth;
2774 return $kid . "(" . $args . ")"; # parens mandatory
2780 # returns "&" if the prototype doesn't match the args,
2781 # or ("", $args_after_prototype_demunging) if it does.
2784 return "&" if $self->{'noproto'};
2785 my($proto, @args) = @_;
2789 # An unbackslashed @ or % gobbles up the rest of the args
2790 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
2792 $proto =~ s/^(\\?[\$\@&%*]|\\\[[\$\@&%*]+\]|;)//;
2795 return "&" if @args;
2796 } elsif ($chr eq ";") {
2798 } elsif ($chr eq "@" or $chr eq "%") {
2799 push @reals, map($self->deparse($_, 6), @args);
2805 if (want_scalar $arg) {
2806 push @reals, $self->deparse($arg, 6);
2810 } elsif ($chr eq "&") {
2811 if ($arg->name =~ /^(s?refgen|undef)$/) {
2812 push @reals, $self->deparse($arg, 6);
2816 } elsif ($chr eq "*") {
2817 if ($arg->name =~ /^s?refgen$/
2818 and $arg->first->first->name eq "rv2gv")
2820 $real = $arg->first->first; # skip refgen, null
2821 if ($real->first->name eq "gv") {
2822 push @reals, $self->deparse($real, 6);
2824 push @reals, $self->deparse($real->first, 6);
2829 } elsif (substr($chr, 0, 1) eq "\\") {
2831 if ($arg->name =~ /^s?refgen$/ and
2832 !null($real = $arg->first) and
2833 ($chr =~ /\$/ && is_scalar($real->first)
2835 && class($real->first->sibling) ne 'NULL'
2836 && $real->first->sibling->name
2839 && class($real->first->sibling) ne 'NULL'
2840 && $real->first->sibling->name
2842 #or ($chr =~ /&/ # This doesn't work
2843 # && $real->first->name eq "rv2cv")
2845 && $real->first->name eq "rv2gv")))
2847 push @reals, $self->deparse($real, 6);
2854 return "&" if $proto and !$doneok; # too few args and no `;'
2855 return "&" if @args; # too many args
2856 return ("", join ", ", @reals);
2862 return $self->method($op, $cx) unless null $op->first->sibling;
2866 if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
2868 } elsif ($op->private & OPpENTERSUB_AMPER) {
2872 $kid = $kid->first->sibling; # skip ex-list, pushmark
2873 for (; not null $kid->sibling; $kid = $kid->sibling) {
2878 if (is_scope($kid)) {
2880 $kid = "{" . $self->deparse($kid, 0) . "}";
2881 } elsif ($kid->first->name eq "gv") {
2882 my $gv = $self->gv_or_padgv($kid->first);
2883 if (class($gv->CV) ne "SPECIAL") {
2884 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2886 $simple = 1; # only calls of named functions can be prototyped
2887 $kid = $self->deparse($kid, 24);
2888 } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
2890 $kid = $self->deparse($kid, 24);
2893 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2894 $kid = $self->deparse($kid, 24) . $arrow;
2897 # Doesn't matter how many prototypes there are, if
2898 # they haven't happened yet!
2902 no warnings 'uninitialized';
2903 $declared = exists $self->{'subs_declared'}{$kid}
2905 defined &{ %{$self->{'curstash'}."::"}->{$kid} }
2907 $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
2908 && defined prototype $self->{'curstash'}."::".$kid
2910 if (!$declared && defined($proto)) {
2911 # Avoid "too early to check prototype" warning
2912 ($amper, $proto) = ('&');
2917 if ($declared and defined $proto and not $amper) {
2918 ($amper, $args) = $self->check_proto($proto, @exprs);
2919 if ($amper eq "&") {
2920 $args = join(", ", map($self->deparse($_, 6), @exprs));
2923 $args = join(", ", map($self->deparse($_, 6), @exprs));
2925 if ($prefix or $amper) {
2926 if ($op->flags & OPf_STACKED) {
2927 return $prefix . $amper . $kid . "(" . $args . ")";
2929 return $prefix . $amper. $kid;
2932 # glob() invocations can be translated into calls of
2933 # CORE::GLOBAL::glob with a second parameter, a number.
2935 if ($kid eq "CORE::GLOBAL::glob") {
2937 $args =~ s/\s*,[^,]+$//;
2940 # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
2941 # so it must have been translated from a keyword call. Translate
2943 $kid =~ s/^CORE::GLOBAL:://;
2946 return "$kid(" . $args . ")";
2947 } elsif (defined $proto and $proto eq "") {
2949 } elsif (defined $proto and $proto eq "\$" and is_scalar($exprs[0])) {
2950 return $self->maybe_parens_func($kid, $args, $cx, 16);
2951 } elsif (defined($proto) && $proto or $simple) {
2952 return $self->maybe_parens_func($kid, $args, $cx, 5);
2954 return "$kid(" . $args . ")";
2959 sub pp_enterwrite { unop(@_, "write") }
2961 # escape things that cause interpolation in double quotes,
2962 # but not character escapes
2965 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
2973 # Matches any string which is balanced with respect to {braces}
2984 # the same, but treat $|, $), $( and $ at the end of the string differently
2998 (\(\?\??\{$bal\}\)) # $4
3004 /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3009 # This is for regular expressions with the /x modifier
3010 # We have to leave comments unmangled.
3011 sub re_uninterp_extended {
3024 ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
3025 | \#[^\n]* # (skip over comments)
3032 /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3038 # character escapes, but not delimiters that might need to be escaped
3039 sub escape_str { # ASCII, UTF8
3041 $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3043 # $str =~ s/\cH/\\b/g; # \b means something different in a regex
3049 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
3050 $str =~ s/([^[:print:]])/'\\' . sprintf("%03o", ord($1))/ge;
3054 # For regexes with the /x modifier.
3055 # Leave whitespace unmangled.
3056 sub escape_extended_re {
3058 $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3059 $str =~ s/([^[:print:]])/'\\' . sprintf("%03o", ord($1))/ge;
3060 $str =~ s/\n/\n\f/g;
3064 # Don't do this for regexen
3067 $str =~ s/\\/\\\\/g;
3071 # Remove backslashes which precede literal control characters,
3072 # to avoid creating ambiguity when we escape the latter.
3076 # the insane complexity here is due to the behaviour of "\c\"
3077 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[^[:print:]])/$1$2/g;
3081 sub balanced_delim {
3083 my @str = split //, $str;
3084 my($ar, $open, $close, $fail, $c, $cnt);
3085 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
3086 ($open, $close) = @$ar;
3087 $fail = 0; $cnt = 0;
3091 } elsif ($c eq $close) {
3100 $fail = 1 if $cnt != 0;
3101 return ($open, "$open$str$close") if not $fail;
3107 my($q, $default, $str) = @_;
3108 return "$default$str$default" if $default and index($str, $default) == -1;
3110 (my $succeed, $str) = balanced_delim($str);
3111 return "$q$str" if $succeed;
3113 for my $delim ('/', '"', '#') {
3114 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3117 $str =~ s/$default/\\$default/g;
3118 return "$default$str$default";
3127 if (class($sv) eq "SPECIAL") {
3128 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
3129 } elsif (class($sv) eq "NULL") {
3131 } elsif ($sv->FLAGS & SVf_IOK) {
3132 return $sv->int_value;
3133 } elsif ($sv->FLAGS & SVf_NOK) {
3134 # try the default stringification
3137 # If it's in scientific notation, we might have lost information
3138 return sprintf("%.20e", $sv->NV);
3141 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3142 return "\\(" . const($sv->RV) . ")"; # constant folded
3143 } elsif ($sv->FLAGS & SVf_POK) {
3145 if ($str =~ /[^ -~]/) { # ASCII for non-printing
3146 return single_delim("qq", '"', uninterp escape_str unback $str);
3148 return single_delim("q", "'", unback $str);
3159 # the constant could be in the pad (under useithreads)
3160 $sv = $self->padval($op->targ) unless $$sv;
3167 if ($op->private & OPpCONST_ARYBASE) {
3170 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3171 # return $self->const_sv($op)->PV;
3173 my $sv = $self->const_sv($op);
3174 # return const($sv);
3176 return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
3182 my $type = $op->name;
3183 if ($type eq "const") {
3184 return '$[' if $op->private & OPpCONST_ARYBASE;
3185 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3186 } elsif ($type eq "concat") {
3187 my $first = $self->dq($op->first);
3188 my $last = $self->dq($op->last);
3190 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3191 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3192 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
3193 || ($last =~ /^[{\[\w_]/ &&
3194 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3196 return $first . $last;
3197 } elsif ($type eq "uc") {
3198 return '\U' . $self->dq($op->first->sibling) . '\E';
3199 } elsif ($type eq "lc") {
3200 return '\L' . $self->dq($op->first->sibling) . '\E';
3201 } elsif ($type eq "ucfirst") {
3202 return '\u' . $self->dq($op->first->sibling);
3203 } elsif ($type eq "lcfirst") {
3204 return '\l' . $self->dq($op->first->sibling);
3205 } elsif ($type eq "quotemeta") {
3206 return '\Q' . $self->dq($op->first->sibling) . '\E';
3207 } elsif ($type eq "join") {
3208 return $self->deparse($op->last, 26); # was join($", @ary)
3210 return $self->deparse($op, 26);
3218 return single_delim("qx", '`', $self->dq($op->first->sibling));
3224 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3225 return $self->deparse($kid, $cx) if $self->{'unquote'};
3226 $self->maybe_targmy($kid, $cx,
3227 sub {single_delim("qq", '"', $self->dq($_[1]))});
3230 # OP_STRINGIFY is a listop, but it only ever has one arg
3231 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3233 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3234 # note that tr(from)/to/ is OK, but not tr/from/(to)
3236 my($from, $to) = @_;
3237 my($succeed, $delim);
3238 if ($from !~ m[/] and $to !~ m[/]) {
3239 return "/$from/$to/";
3240 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3241 if (($succeed, $to) = balanced_delim($to) and $succeed) {
3244 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3245 return "$from$delim$to$delim" if index($to, $delim) == -1;
3248 return "$from/$to/";
3251 for $delim ('/', '"', '#') { # note no '
3252 return "$delim$from$delim$to$delim"
3253 if index($to . $from, $delim) == -1;
3255 $from =~ s[/][\\/]g;
3257 return "/$from/$to/";
3261 # Only used by tr///, so backslashes hyphens
3264 if ($n == ord '\\') {
3266 } elsif ($n == ord "-") {
3268 } elsif ($n >= ord(' ') and $n <= ord('~')) {
3270 } elsif ($n == ord "\a") {
3272 } elsif ($n == ord "\b") {
3274 } elsif ($n == ord "\t") {
3276 } elsif ($n == ord "\n") {
3278 } elsif ($n == ord "\e") {
3280 } elsif ($n == ord "\f") {
3282 } elsif ($n == ord "\r") {
3284 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3285 return '\\c' . chr(ord("@") + $n);
3287 # return '\x' . sprintf("%02x", $n);
3288 return '\\' . sprintf("%03o", $n);
3294 my($str, $c, $tr) = ("");
3295 for ($c = 0; $c < @chars; $c++) {
3298 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3299 $chars[$c + 2] == $tr + 2)
3301 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3304 $str .= pchr($chars[$c]);
3310 sub tr_decode_byte {
3311 my($table, $flags) = @_;
3312 my(@table) = unpack("s*", $table);
3313 splice @table, 0x100, 1; # Number of subsequent elements
3314 my($c, $tr, @from, @to, @delfrom, $delhyphen);
3315 if ($table[ord "-"] != -1 and
3316 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3318 $tr = $table[ord "-"];
3319 $table[ord "-"] = -1;
3323 } else { # -2 ==> delete
3327 for ($c = 0; $c < @table; $c++) {
3330 push @from, $c; push @to, $tr;
3331 } elsif ($tr == -2) {
3335 @from = (@from, @delfrom);
3336 if ($flags & OPpTRANS_COMPLEMENT) {
3339 @from{@from} = (1) x @from;
3340 for ($c = 0; $c < 256; $c++) {
3341 push @newfrom, $c unless $from{$c};
3345 unless ($flags & OPpTRANS_DELETE || !@to) {
3346 pop @to while $#to and $to[$#to] == $to[$#to -1];
3349 $from = collapse(@from);
3350 $to = collapse(@to);
3351 $from .= "-" if $delhyphen;
3352 return ($from, $to);
3357 if ($x == ord "-") {
3359 } elsif ($x == ord "\\") {
3366 # XXX This doesn't yet handle all cases correctly either
3368 sub tr_decode_utf8 {
3369 my($swash_hv, $flags) = @_;
3370 my %swash = $swash_hv->ARRAY;
3372 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3373 my $none = $swash{"NONE"}->IV;
3374 my $extra = $none + 1;
3375 my(@from, @delfrom, @to);
3377 foreach $line (split /\n/, $swash{'LIST'}->PV) {
3378 my($min, $max, $result) = split(/\t/, $line);
3385 $result = hex $result;
3386 if ($result == $extra) {
3387 push @delfrom, [$min, $max];
3389 push @from, [$min, $max];
3390 push @to, [$result, $result + $max - $min];
3393 for my $i (0 .. $#from) {
3394 if ($from[$i][0] == ord '-') {
3395 unshift @from, splice(@from, $i, 1);
3396 unshift @to, splice(@to, $i, 1);
3398 } elsif ($from[$i][1] == ord '-') {
3401 unshift @from, ord '-';
3402 unshift @to, ord '-';
3406 for my $i (0 .. $#delfrom) {
3407 if ($delfrom[$i][0] == ord '-') {
3408 push @delfrom, splice(@delfrom, $i, 1);
3410 } elsif ($delfrom[$i][1] == ord '-') {
3412 push @delfrom, ord '-';
3416 if (defined $final and $to[$#to][1] != $final) {
3417 push @to, [$final, $final];
3419 push @from, @delfrom;
3420 if ($flags & OPpTRANS_COMPLEMENT) {
3423 for my $i (0 .. $#from) {
3424 push @newfrom, [$next, $from[$i][0] - 1];
3425 $next = $from[$i][1] + 1;
3428 for my $range (@newfrom) {
3429 if ($range->[0] <= $range->[1]) {
3434 my($from, $to, $diff);
3435 for my $chunk (@from) {
3436 $diff = $chunk->[1] - $chunk->[0];
3438 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3439 } elsif ($diff == 1) {
3440 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3442 $from .= tr_chr($chunk->[0]);
3445 for my $chunk (@to) {
3446 $diff = $chunk->[1] - $chunk->[0];
3448 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3449 } elsif ($diff == 1) {
3450 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3452 $to .= tr_chr($chunk->[0]);
3455 #$final = sprintf("%04x", $final) if defined $final;
3456 #$none = sprintf("%04x", $none) if defined $none;
3457 #$extra = sprintf("%04x", $extra) if defined $extra;
3458 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3459 #print STDERR $swash{'LIST'}->PV;
3460 return (escape_str($from), escape_str($to));
3467 if (class($op) eq "PVOP") {
3468 ($from, $to) = tr_decode_byte($op->pv, $op->private);
3469 } else { # class($op) eq "SVOP"
3470 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3473 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3474 $flags .= "d" if $op->private & OPpTRANS_DELETE;
3475 $to = "" if $from eq $to and $flags eq "";
3476 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3477 return "tr" . double_delim($from, $to) . $flags;
3480 # Like dq(), but different
3483 my ($op, $extended) = @_;
3485 my $type = $op->name;
3486 if ($type eq "const") {
3487 return '$[' if $op->private & OPpCONST_ARYBASE;
3488 my $unbacked = re_unback($self->const_sv($op)->as_string);
3489 return re_uninterp_extended(escape_extended_re($unbacked))
3491 return re_uninterp(escape_str($unbacked));
3492 } elsif ($type eq "concat") {
3493 my $first = $self->re_dq($op->first, $extended);
3494 my $last = $self->re_dq($op->last, $extended);
3496 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3497 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3498 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
3499 || ($last =~ /^[{\[\w_]/ &&
3500 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3502 return $first . $last;
3503 } elsif ($type eq "uc") {
3504 return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
3505 } elsif ($type eq "lc") {
3506 return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
3507 } elsif ($type eq "ucfirst") {
3508 return '\u' . $self->re_dq($op->first->sibling, $extended);
3509 } elsif ($type eq "lcfirst") {
3510 return '\l' . $self->re_dq($op->first->sibling, $extended);
3511 } elsif ($type eq "quotemeta") {
3512 return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
3513 } elsif ($type eq "join") {
3514 return $self->deparse($op->last, 26); # was join($", @ary)
3516 return $self->deparse($op, 26);
3521 my ($self, $op) = @_;
3522 my $type = $op->name;
3524 if ($type eq 'const') {
3527 elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
3528 return $self->pure_string($op->first->sibling);
3530 elsif ($type eq 'join') {
3531 my $join_op = $op->first->sibling; # Skip pushmark
3532 return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
3534 my $gvop = $join_op->first;
3535 return 0 unless $gvop->name eq 'gvsv';
3536 return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
3538 return 0 unless ${$join_op->sibling} eq ${$op->last};
3539 return 0 unless $op->last->name =~ /^(rv2|pad)av$/;
3541 elsif ($type eq 'concat') {
3542 return $self->pure_string($op->first)
3543 && $self->pure_string($op->last);
3545 elsif (is_scalar($op) || $type =~ /^[ah]elem(fast)?$/) {
3557 my($op, $cx, $extended) = @_;
3558 my $kid = $op->first;
3559 $kid = $kid->first if $kid->name eq "regcmaybe";
3560 $kid = $kid->first if $kid->name eq "regcreset";
3561 return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
3562 return ($self->deparse($kid, $cx), 0);
3566 my ($self, $op, $cx) = @_;
3567 return (($self->regcomp($op, $cx, 0))[0]);
3570 # osmic acid -- see osmium tetroxide
3573 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3574 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3575 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3579 my($op, $cx, $name, $delim) = @_;
3580 my $kid = $op->first;
3581 my ($binop, $var, $re) = ("", "", "");
3582 if ($op->flags & OPf_STACKED) {
3584 $var = $self->deparse($kid, 20);
3585 $kid = $kid->sibling;
3588 my $extended = ($op->pmflags & PMf_EXTENDED);
3590 my $unbacked = re_unback($op->precomp);
3592 $re = re_uninterp_extended(escape_extended_re($unbacked));
3594 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3596 } elsif ($kid->name ne 'regcomp') {
3597 carp("found ".$kid->name." where regcomp expected");
3599 ($re, $quote) = $self->regcomp($kid, 1, $extended);
3602 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3603 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3604 $flags .= "i" if $op->pmflags & PMf_FOLD;
3605 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3606 $flags .= "o" if $op->pmflags & PMf_KEEP;
3607 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3608 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3609 $flags = $matchwords{$flags} if $matchwords{$flags};
3610 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3614 $re = single_delim($name, $delim, $re);
3616 $re = $re . $flags if $quote;
3618 return $self->maybe_parens("$var =~ $re", $cx, 20);
3624 sub pp_match { matchop(@_, "m", "/") }
3625 sub pp_pushre { matchop(@_, "m", "/") }
3626 sub pp_qr { matchop(@_, "qr", "") }
3631 my($kid, @exprs, $ary, $expr);
3633 # under ithreads pmreplroot is an integer, not an SV
3634 my $replroot = $kid->pmreplroot;
3635 if ( ( ref($replroot) && $$replroot ) ||
3636 ( !ref($replroot) && $replroot ) ) {
3637 $ary = $self->stash_variable('@', $self->gv_name($kid->pmreplroot));
3639 for (; !null($kid); $kid = $kid->sibling) {
3640 push @exprs, $self->deparse($kid, 6);
3643 # handle special case of split(), and split(" ") that compiles to /\s+/
3645 if ($kid->flags & OPf_SPECIAL
3646 && $exprs[0] eq '/\\s+/'
3647 && $kid->pmflags & PMf_SKIPWHITE ) {
3651 $expr = "split(" . join(", ", @exprs) . ")";
3653 return $self->maybe_parens("$ary = $expr", $cx, 7);
3659 # oxime -- any of various compounds obtained chiefly by the action of
3660 # hydroxylamine on aldehydes and ketones and characterized by the
3661 # bivalent grouping C=NOH [Webster's Tenth]
3664 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3665 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3666 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3667 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3672 my $kid = $op->first;
3673 my($binop, $var, $re, $repl) = ("", "", "", "");
3674 if ($op->flags & OPf_STACKED) {
3676 $var = $self->deparse($kid, 20);
3677 $kid = $kid->sibling;
3680 if (null($op->pmreplroot)) {
3681 $repl = $self->dq($kid);
3682 $kid = $kid->sibling;
3684 $repl = $op->pmreplroot->first; # skip substcont
3685 while ($repl->name eq "entereval") {
3686 $repl = $repl->first;
3689 if ($op->pmflags & PMf_EVAL) {
3690 $repl = $self->deparse($repl, 0);
3692 $repl = $self->dq($repl);
3695 my $extended = ($op->pmflags & PMf_EXTENDED);
3697 my $unbacked = re_unback($op->precomp);
3699 $re = re_uninterp_extended(escape_extended_re($unbacked));
3702 $re = re_uninterp(escape_str($unbacked));
3705 ($re) = $self->regcomp($kid, 1, $extended);
3707 $flags .= "e" if $op->pmflags & PMf_EVAL;
3708 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3709 $flags .= "i" if $op->pmflags & PMf_FOLD;
3710 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3711 $flags .= "o" if $op->pmflags & PMf_KEEP;
3712 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3713 $flags .= "x" if $extended;
3714 $flags = $substwords{$flags} if $substwords{$flags};
3716 return $self->maybe_parens("$var =~ s"
3717 . double_delim($re, $repl) . $flags,
3720 return "s". double_delim($re, $repl) . $flags;
3729 B::Deparse - Perl compiler backend to produce perl code
3733 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3734 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3738 B::Deparse is a backend module for the Perl compiler that generates
3739 perl source code, based on the internal compiled structure that perl
3740 itself creates after parsing a program. The output of B::Deparse won't
3741 be exactly the same as the original source, since perl doesn't keep
3742 track of comments or whitespace, and there isn't a one-to-one
3743 correspondence between perl's syntactical constructions and their
3744 compiled form, but it will often be close. When you use the B<-p>
3745 option, the output also includes parentheses even when they are not
3746 required by precedence, which can make it easy to see if perl is
3747 parsing your expressions the way you intended.
3749 Please note that this module is mainly new and untested code and is
3750 still under development, so it may change in the future.
3754 As with all compiler backend options, these must follow directly after
3755 the '-MO=Deparse', separated by a comma but not any white space.
3761 Add '#line' declarations to the output based on the line and file
3762 locations of the original code.
3766 Print extra parentheses. Without this option, B::Deparse includes
3767 parentheses in its output only when they are needed, based on the
3768 structure of your program. With B<-p>, it uses parentheses (almost)
3769 whenever they would be legal. This can be useful if you are used to
3770 LISP, or if you want to see how perl parses your input. If you say
3772 if ($var & 0x7f == 65) {print "Gimme an A!"}
3773 print ($which ? $a : $b), "\n";
3774 $name = $ENV{USER} or "Bob";
3776 C<B::Deparse,-p> will print
3779 print('Gimme an A!')
3781 (print(($which ? $a : $b)), '???');
3782 (($name = $ENV{'USER'}) or '???')
3784 which probably isn't what you intended (the C<'???'> is a sign that
3785 perl optimized away a constant value).
3789 Disable prototype checking. With this option, all function calls are
3790 deparsed as if no prototype was defined for them. In other words,
3792 perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
3801 making clear how the parameters are actually passed to C<foo>.
3805 Expand double-quoted strings into the corresponding combinations of
3806 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3809 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3813 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3814 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3816 Note that the expanded form represents the way perl handles such
3817 constructions internally -- this option actually turns off the reverse
3818 translation that B::Deparse usually does. On the other hand, note that
3819 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3820 of $y into a string before doing the assignment.
3824 Normally, B::Deparse deparses the main code of a program, and all the subs
3825 defined in the same file. To include subs defined in other files, pass the
3826 B<-f> option with the filename. You can pass the B<-f> option several times, to
3827 include more than one secondary file. (Most of the time you don't want to
3828 use it at all.) You can also use this option to include subs which are
3829 defined in the scope of a B<#line> directive with two parameters.
3831 =item B<-s>I<LETTERS>
3833 Tweak the style of B::Deparse's output. The letters should follow
3834 directly after the 's', with no space or punctuation. The following
3835 options are available:
3841 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3858 The default is not to cuddle.
3862 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3866 Use tabs for each 8 columns of indent. The default is to use only spaces.
3867 For instance, if the style options are B<-si4T>, a line that's indented
3868 3 times will be preceded by one tab and four spaces; if the options were
3869 B<-si8T>, the same line would be preceded by three tabs.
3871 =item B<v>I<STRING>B<.>
3873 Print I<STRING> for the value of a constant that can't be determined
3874 because it was optimized away (mnemonic: this happens when a constant
3875 is used in B<v>oid context). The end of the string is marked by a period.
3876 The string should be a valid perl expression, generally a constant.
3877 Note that unless it's a number, it probably needs to be quoted, and on
3878 a command line quotes need to be protected from the shell. Some
3879 conventional values include 0, 1, 42, '', 'foo', and
3880 'Useless use of constant omitted' (which may need to be
3881 B<-sv"'Useless use of constant omitted'.">
3882 or something similar depending on your shell). The default is '???'.
3883 If you're using B::Deparse on a module or other file that's require'd,
3884 you shouldn't use a value that evaluates to false, since the customary
3885 true constant at the end of a module will be in void context when the
3886 file is compiled as a main program.
3892 Expand conventional syntax constructions into equivalent ones that expose
3893 their internal operation. I<LEVEL> should be a digit, with higher values
3894 meaning more expansion. As with B<-q>, this actually involves turning off
3895 special cases in B::Deparse's normal operations.
3897 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3898 while loops with continue blocks; for instance
3900 for ($i = 0; $i < 10; ++$i) {
3913 Note that in a few cases this translation can't be perfectly carried back
3914 into the source code -- if the loop's initializer declares a my variable,
3915 for instance, it won't have the correct scope outside of the loop.
3917 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3918 expressions using C<&&>, C<?:> and C<do {}>; for instance
3920 print 'hi' if $nice;
3932 $nice and print 'hi';
3933 $nice and do { print 'hi' };
3934 $nice ? do { print 'hi' } : do { print 'bye' };
3936 Long sequences of elsifs will turn into nested ternary operators, which
3937 B::Deparse doesn't know how to indent nicely.
3941 =head1 USING B::Deparse AS A MODULE
3946 $deparse = B::Deparse->new("-p", "-sC");
3947 $body = $deparse->coderef2text(\&func);
3948 eval "sub func $body"; # the inverse operation
3952 B::Deparse can also be used on a sub-by-sub basis from other perl
3957 $deparse = B::Deparse->new(OPTIONS)
3959 Create an object to store the state of a deparsing operation and any
3960 options. The options are the same as those that can be given on the
3961 command line (see L</OPTIONS>); options that are separated by commas
3962 after B<-MO=Deparse> should be given as separate strings. Some
3963 options, like B<-u>, don't make sense for a single subroutine, so
3966 =head2 ambient_pragmas
3968 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3970 The compilation of a subroutine can be affected by a few compiler
3971 directives, B<pragmas>. These are:
3985 Assigning to the special variable $[
4005 Ordinarily, if you use B::Deparse on a subroutine which has
4006 been compiled in the presence of one or more of these pragmas,
4007 the output will include statements to turn on the appropriate
4008 directives. So if you then compile the code returned by coderef2text,
4009 it will behave the same way as the subroutine which you deparsed.
4011 However, you may know that you intend to use the results in a
4012 particular context, where some pragmas are already in scope. In
4013 this case, you use the B<ambient_pragmas> method to describe the
4014 assumptions you wish to make.
4016 Not all of the options currently have any useful effect. See
4017 L</BUGS> for more details.
4019 The parameters it accepts are:
4025 Takes a string, possibly containing several values separated
4026 by whitespace. The special values "all" and "none" mean what you'd
4029 $deparse->ambient_pragmas(strict => 'subs refs');
4033 Takes a number, the value of the array base $[.
4041 If the value is true, then the appropriate pragma is assumed to
4042 be in the ambient scope, otherwise not.
4046 Takes a string, possibly containing a whitespace-separated list of
4047 values. The values "all" and "none" are special. It's also permissible
4048 to pass an array reference here.
4050 $deparser->ambient_pragmas(re => 'eval');
4055 Takes a string, possibly containing a whitespace-separated list of
4056 values. The values "all" and "none" are special, again. It's also
4057 permissible to pass an array reference here.
4059 $deparser->ambient_pragmas(warnings => [qw[void io]]);
4061 If one of the values is the string "FATAL", then all the warnings
4062 in that list will be considered fatal, just as with the B<warnings>
4063 pragma itself. Should you need to specify that some warnings are
4064 fatal, and others are merely enabled, you can pass the B<warnings>
4067 $deparser->ambient_pragmas(
4069 warnings => [FATAL => qw/void io/],
4072 See L<perllexwarn> for more information about lexical warnings.
4078 These two parameters are used to specify the ambient pragmas in
4079 the format used by the special variables $^H and ${^WARNING_BITS}.
4081 They exist principally so that you can write code like:
4083 { my ($hint_bits, $warning_bits);
4084 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
4085 $deparser->ambient_pragmas (
4086 hint_bits => $hint_bits,
4087 warning_bits => $warning_bits,
4091 which specifies that the ambient pragmas are exactly those which
4092 are in scope at the point of calling.
4098 $body = $deparse->coderef2text(\&func)
4099 $body = $deparse->coderef2text(sub ($$) { ... })
4101 Return source code for the body of a subroutine (a block, optionally
4102 preceded by a prototype in parens), given a reference to the
4103 sub. Because a subroutine can have no names, or more than one name,
4104 this method doesn't return a complete subroutine definition -- if you
4105 want to eval the result, you should prepend "sub subname ", or "sub "
4106 for an anonymous function constructor. Unless the sub was defined in
4107 the main:: package, the code will include a package declaration.
4115 The only pragmas to be completely supported are: C<use warnings>,
4116 C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
4117 behaves like a pragma, is also supported.)
4119 Excepting those listed above, we're currently unable to guarantee that
4120 B::Deparse will produce a pragma at the correct point in the program.
4121 Since the effects of pragmas are often lexically scoped, this can mean
4122 that the pragma holds sway over a different portion of the program
4123 than in the input file.
4127 In fact, the above is a specific instance of a more general problem:
4128 we can't guarantee to produce BEGIN blocks or C<use> declarations in
4129 exactly the right place. So if you use a module which affects compilation
4130 (such as by over-riding keywords, overloading constants or whatever)
4131 then the output code might not work as intended.
4133 This is the most serious outstanding problem, and will be very hard
4138 If a keyword is over-ridden, and your program explicitly calls
4139 the built-in version by using CORE::keyword, the output of B::Deparse
4140 will not reflect this. If you run the resulting code, it will call
4141 the over-ridden version rather than the built-in one. (Maybe there
4142 should be an option to B<always> print keyword calls as C<CORE::name>.)
4146 C<sort foo (1, 2, 3)> comes out as C<sort (foo 1, 2, 3)>, which
4147 causes perl to issue a warning.
4149 The obvious fix doesn't work, because these are different:
4151 print (FOO 1, 2, 3), 4, 5, 6;
4152 print FOO (1, 2, 3), 4, 5, 6;
4156 Constants (other than simple strings or numbers) don't work properly.
4157 Pathological examples that fail (and probably always will) include:
4159 use constant E2BIG => ($!=7);
4160 use constant x=>\$x; print x
4162 The following could (and should) be made to work:
4164 use constant regex => qr/blah/;
4169 An input file that uses source filtering probably won't be deparsed into
4170 runnable code, because it will still include the B<use> declaration
4171 for the source filtering module, even though the code that is
4172 produced is already ordinary Perl which shouldn't be filtered again.
4176 There are probably many more bugs on non-ASCII platforms (EBCDIC).
4182 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
4183 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
4184 contributions from Gisle Aas, James Duncan, Albert Dvornik, Robin
4185 Houston, Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons,
4186 and Rafael Garcia-Suarez.