2 # Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved.
3 # This module is free software; you can redistribute and/or modify
4 # it under the same terms as Perl itself.
6 # This is based on the module of the same name by Malcolm Beattie,
7 # but essentially none of his code remains.
10 use Carp 'cluck', 'croak';
11 use B qw(class main_root main_start main_cv svref_2object opnumber cstring
12 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
13 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
14 OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
15 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
16 OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
18 SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR
19 CVf_METHOD CVf_LOCKED CVf_LVALUE
20 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
21 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
26 # Changes between 0.50 and 0.51:
27 # - fixed nulled leave with live enter in sort { }
28 # - fixed reference constants (\"str")
29 # - handle empty programs gracefully
30 # - handle infinte loops (for (;;) {}, while (1) {})
31 # - differentiate between `for my $x ...' and `my $x; for $x ...'
32 # - various minor cleanups
33 # - moved globals into an object
34 # - added `-u', like B::C
35 # - package declarations using cop_stash
36 # - subs, formats and code sorted by cop_seq
37 # Changes between 0.51 and 0.52:
38 # - added pp_threadsv (special variables under USE_THREADS)
39 # - added documentation
40 # Changes between 0.52 and 0.53:
41 # - many changes adding precedence contexts and associativity
42 # - added `-p' and `-s' output style options
43 # - various other minor fixes
44 # Changes between 0.53 and 0.54:
45 # - added support for new `for (1..100)' optimization,
47 # Changes between 0.54 and 0.55:
48 # - added support for new qr// construct
49 # - added support for new pp_regcreset OP
50 # Changes between 0.55 and 0.56:
51 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
52 # - fixed $# on non-lexicals broken in last big rewrite
53 # - added temporary fix for change in opcode of OP_STRINGIFY
54 # - fixed problem in 0.54's for() patch in `for (@ary)'
55 # - fixed precedence in conditional of ?:
56 # - tweaked list paren elimination in `my($x) = @_'
57 # - made continue-block detection trickier wrt. null ops
58 # - fixed various prototype problems in pp_entersub
59 # - added support for sub prototypes that never get GVs
60 # - added unquoting for special filehandle first arg in truncate
61 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
62 # - added semicolons at the ends of blocks
63 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
64 # Changes between 0.56 and 0.561:
65 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
66 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
67 # Changes between 0.561 and 0.57:
68 # - stylistic changes to symbolic constant stuff
69 # - handled scope in s///e replacement code
70 # - added unquote option for expanding "" into concats, etc.
71 # - split method and proto parts of pp_entersub into separate functions
72 # - various minor cleanups
74 # - added parens in \&foo (patch by Albert Dvornik)
75 # Changes between 0.57 and 0.58:
76 # - fixed `0' statements that weren't being printed
77 # - added methods for use from other programs
78 # (based on patches from James Duncan and Hugo van der Sanden)
79 # - added -si and -sT to control indenting (also based on a patch from Hugo)
80 # - added -sv to print something else instead of '???'
81 # - preliminary version of utf8 tr/// handling
83 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
84 # - added support for Hugo's new OP_SETSTATE (like nextstate)
85 # Changes between 0.58 and 0.59
86 # - added support for Chip's OP_METHOD_NAMED
87 # - added support for Ilya's OPpTARGET_MY optimization
88 # - elided arrows before `()' subscripts when possible
89 # Changes between 0.59 and 0.60
90 # - support for method attribues was added
91 # - some warnings fixed
92 # - separate recognition of constant subs
93 # - rewrote continue block handling, now recoginizing for loops
94 # - added more control of expanding control structures
97 # (See also BUGS section at the end of this file)
99 # - finish tr/// changes
100 # - add option for even more parens (generalize \&foo change)
101 # - left/right context
102 # - treat top-level block specially for incremental output
103 # - copy comments (look at real text with $^P?)
104 # - avoid semis in one-statement blocks
105 # - associativity of &&=, ||=, ?:
106 # - ',' => '=>' (auto-unquote?)
107 # - break long lines ("\r" as discretionary break?)
108 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
109 # - more style options: brace style, hex vs. octal, quotes, ...
110 # - print big ints as hex/octal instead of decimal (heuristic?)
111 # - handle `my $x if 0'?
112 # - coordinate with Data::Dumper (both directions? see previous)
113 # - version using op_next instead of op_first/sibling?
114 # - avoid string copies (pass arrays, one big join?)
117 # Tests that will always fail:
118 # (see t/TEST for the short list)
120 # Object fields (were globals):
123 # (local($a), local($b)) and local($a, $b) have the same internal
124 # representation but the short form looks better. We notice we can
125 # use a large-scale local when checking the list, but need to prevent
126 # individual locals too. This hash holds the addresses of OPs that
127 # have already had their local-ness accounted for. The same thing
131 # CV for current sub (or main program) being deparsed
134 # Cached hash of lexical variables for curcv: keys are names,
135 # each value is an array of pairs, indicating the cop_seq of scopes
136 # in which a var of that name is valid.
139 # COP for statement being deparsed
142 # name of the current package for deparsed code
145 # array of [cop_seq, CV, is_format?] for subs and formats we still
149 # as above, but [name, prototype] for subs that never got a GV
151 # subs_done, forms_done:
152 # keys are addresses of GVs for subs and formats we've already
153 # deparsed (or at least put into subs_todo)
156 # keys are names of subs for which we've printed declarations.
157 # That means we can omit parentheses from the arguments.
162 # cuddle: ` ' or `\n', depending on -sC
167 # A little explanation of how precedence contexts and associativity
170 # deparse() calls each per-op subroutine with an argument $cx (short
171 # for context, but not the same as the cx* in the perl core), which is
172 # a number describing the op's parents in terms of precedence, whether
173 # they're inside an expression or at statement level, etc. (see
174 # chart below). When ops with children call deparse on them, they pass
175 # along their precedence. Fractional values are used to implement
176 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
177 # parentheses hacks. The major disadvantage of this scheme is that
178 # it doesn't know about right sides and left sides, so say if you
179 # assign a listop to a variable, it can't tell it's allowed to leave
180 # the parens off the listop.
183 # 26 [TODO] inside interpolation context ("")
184 # 25 left terms and list operators (leftward)
188 # 21 right ! ~ \ and unary + and -
193 # 16 nonassoc named unary operators
194 # 15 nonassoc < > <= >= lt gt le ge
195 # 14 nonassoc == != <=> eq ne cmp
202 # 7 right = += -= *= etc.
204 # 5 nonassoc list operators (rightward)
208 # 1 statement modifiers
211 # Also, lineseq may pass a fourth parameter to the pp_ routines:
212 # if present, the fourth parameter is passed on by deparse.
214 # If present and true, it means that the op exists directly as
215 # part of a lineseq. Currently it's only used by scopeop to
216 # decide whether its results need to be enclosed in a do {} block.
218 # Nonprinting characters with special meaning:
219 # \cS - steal parens (see maybe_parens_unop)
220 # \n - newline and indent
221 # \t - increase indent
222 # \b - decrease indent (`outdent')
223 # \f - flush left (no indent)
224 # \cK - kill following semicolon, if any
228 return class($op) eq "NULL";
233 my($cv, $is_form) = @_;
234 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
236 if (!null($cv->START) and is_state($cv->START)) {
237 $seq = $cv->START->cop_seq;
241 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
246 my $ent = shift @{$self->{'subs_todo'}};
249 my $name = $self->gv_name($gv);
251 return "format $name =\n"
252 . $self->deparse_format($ent->[1]). "\n";
254 $self->{'subs_declared'}{$name} = 1;
255 if ($name eq "BEGIN") {
256 my $use_dec = $self->begin_is_use($cv);
257 if (defined ($use_dec)) {
258 return () if 0 == length($use_dec);
263 if ($self->{'linenums'}) {
264 my $line = $gv->LINE;
265 my $file = $gv->FILE;
266 $l = "\n\f#line $line \"$file\"\n";
268 return "${l}sub $name " . $self->deparse_sub($cv);
272 # Return a "use" declaration for this BEGIN block, if appropriate
274 my ($self, $cv) = @_;
275 my $root = $cv->ROOT;
276 local @$self{qw'curcv curcvlex'} = ($cv);
278 #B::walkoptree($cv->ROOT, "debug");
279 my $lineseq = $root->first;
280 return if $lineseq->name ne "lineseq";
282 my $req_op = $lineseq->first->sibling;
283 return if $req_op->name ne "require";
286 if ($req_op->first->private & OPpCONST_BARE) {
287 # Actually it should always be a bareword
288 $module = $self->const_sv($req_op->first)->PV;
289 $module =~ s[/][::]g;
293 $module = const($self->const_sv($req_op->first));
297 my $version_op = $req_op->sibling;
298 return if class($version_op) eq "NULL";
299 if ($version_op->name eq "lineseq") {
300 # We have a version parameter; skip nextstate & pushmark
301 my $constop = $version_op->first->next->next;
303 return unless $self->const_sv($constop)->PV eq $module;
304 $constop = $constop->sibling;
305 $version = $self->const_sv($constop)->int_value;
306 $constop = $constop->sibling;
307 return if $constop->name ne "method_named";
308 return if $self->const_sv($constop)->PV ne "VERSION";
311 $lineseq = $version_op->sibling;
312 return if $lineseq->name ne "lineseq";
313 my $entersub = $lineseq->first->sibling;
314 if ($entersub->name eq "stub") {
315 return "use $module $version ();\n" if defined $version;
316 return "use $module ();\n";
318 return if $entersub->name ne "entersub";
320 # See if there are import arguments
323 my $svop = $entersub->first->sibling; # Skip over pushmark
324 return unless $self->const_sv($svop)->PV eq $module;
326 # Pull out the arguments
327 for ($svop=$svop->sibling; $svop->name ne "method_named";
328 $svop = $svop->sibling) {
329 $args .= ", " if length($args);
330 $args .= $self->deparse($svop, 6);
334 my $method_named = $svop;
335 return if $method_named->name ne "method_named";
336 my $method_name = $self->const_sv($method_named)->PV;
338 if ($method_name eq "unimport") {
342 # Certain pragmas are dealt with using hint bits,
343 # so we ignore them here
344 if ($module eq 'strict' || $module eq 'integer'
345 || $module eq 'bytes' || $module eq 'warnings') {
349 if (defined $version && length $args) {
350 return "$use $module $version ($args);\n";
351 } elsif (defined $version) {
352 return "$use $module $version;\n";
353 } elsif (length $args) {
354 return "$use $module ($args);\n";
356 return "$use $module;\n";
361 my ($self, $pack) = @_;
363 if (!defined $pack) {
368 $pack =~ s/(::)?$/::/;
372 my %stash = svref_2object($stash)->ARRAY;
373 while (my ($key, $val) = each %stash) {
374 next if $key eq 'main::'; # avoid infinite recursion
375 my $class = class($val);
376 if ($class eq "PV") {
377 # Just a prototype. As an ugly but fairly effective way
378 # to find out if it belongs here is to see if the AUTOLOAD
379 # (if any) for the stash was defined in one of our files.
380 my $A = $stash{"AUTOLOAD"};
381 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
382 && class($A->CV) eq "CV") {
384 next unless $AF eq $0 || exists $self->{'files'}{$AF};
386 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
387 } elsif ($class eq "IV") {
388 # Just a name. As above.
389 my $A = $stash{"AUTOLOAD"};
390 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
391 && class($A->CV) eq "CV") {
393 next unless $AF eq $0 || exists $self->{'files'}{$AF};
395 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
396 } elsif ($class eq "GV") {
397 if (class(my $cv = $val->CV) ne "SPECIAL") {
398 next if $self->{'subs_done'}{$$val}++;
399 next if $$val != ${$cv->GV}; # Ignore imposters
402 if (class(my $cv = $val->FORM) ne "SPECIAL") {
403 next if $self->{'forms_done'}{$$val}++;
404 next if $$val != ${$cv->GV}; # Ignore imposters
407 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
408 $self->stash_subs($pack . $key);
418 foreach $ar (@{$self->{'protos_todo'}}) {
419 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
420 push @ret, "sub " . $ar->[0] . "$proto;\n";
422 delete $self->{'protos_todo'};
430 while (length($opt = substr($opts, 0, 1))) {
432 $self->{'cuddle'} = " ";
433 $opts = substr($opts, 1);
434 } elsif ($opt eq "i") {
435 $opts =~ s/^i(\d+)//;
436 $self->{'indent_size'} = $1;
437 } elsif ($opt eq "T") {
438 $self->{'use_tabs'} = 1;
439 $opts = substr($opts, 1);
440 } elsif ($opt eq "v") {
441 $opts =~ s/^v([^.]*)(.|$)//;
442 $self->{'ex_const'} = $1;
449 my $self = bless {}, $class;
450 $self->{'subs_todo'} = [];
451 $self->{'files'} = {};
452 $self->{'curstash'} = "main";
453 $self->{'curcop'} = undef;
454 $self->{'cuddle'} = "\n";
455 $self->{'indent_size'} = 4;
456 $self->{'use_tabs'} = 0;
457 $self->{'expand'} = 0;
458 $self->{'unquote'} = 0;
459 $self->{'linenums'} = 0;
460 $self->{'parens'} = 0;
461 $self->{'ex_const'} = "'???'";
463 $self->{'ambient_arybase'} = 0;
464 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
465 $self->{'ambient_hints'} = 0;
468 while (my $arg = shift @_) {
469 if ($arg =~ /^-f(.*)/) {
470 $self->{'files'}{$1} = 1;
471 } elsif ($arg eq "-p") {
472 $self->{'parens'} = 1;
473 } elsif ($arg eq "-l") {
474 $self->{'linenums'} = 1;
475 } elsif ($arg eq "-q") {
476 $self->{'unquote'} = 1;
477 } elsif (substr($arg, 0, 2) eq "-s") {
478 $self->style_opts(substr $arg, 2);
479 } elsif ($arg =~ /^-x(\d)$/) {
480 $self->{'expand'} = $1;
487 # Mask out the bits that C<use vars> uses
488 $warnings::Bits{all} | $warnings::DeadBits{all};
491 # Initialise the contextual information, either from
492 # defaults provided with the ambient_pragmas method,
493 # or from perl's own defaults otherwise.
497 $self->{'arybase'} = $self->{'ambient_arybase'};
498 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
499 ? $self->{'ambient_warnings'} & WARN_MASK
501 $self->{'hints'} = $self->{'ambient_hints'} & 0xFF;
503 # also a convenient place to clear out subs_declared
504 delete $self->{'subs_declared'};
510 my $self = B::Deparse->new(@args);
511 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
512 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
513 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
514 for my $block (@BEGINs, @INITs, @ENDs) {
515 $self->todo($block, 0);
518 $self->{'curcv'} = main_cv;
519 $self->{'curcvlex'} = undef;
520 print $self->print_protos;
521 @{$self->{'subs_todo'}} =
522 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
523 print $self->indent($self->deparse(main_root, 0)), "\n"
524 unless null main_root;
526 while (scalar(@{$self->{'subs_todo'}})) {
527 push @text, $self->next_todo;
529 print $self->indent(join("", @text)), "\n" if @text;
531 # Print __DATA__ section, if necessary
533 if (defined *{$self->{'curstash'}."::DATA"}{IO}) {
535 print readline(*{$self->{'curstash'}."::DATA"});
543 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
546 return $self->indent($self->deparse_sub(svref_2object($sub)));
549 sub ambient_pragmas {
551 my ($arybase, $hint_bits, $warning_bits) = (0, 0);
557 if ($name eq 'strict') {
560 if ($val eq 'none') {
561 $hint_bits &= ~strict::bits(qw/refs subs vars/);
567 @names = qw/refs subs vars/;
573 @names = split' ', $val;
575 $hint_bits |= strict::bits(@names);
578 elsif ($name eq '$[') {
582 elsif ($name eq 'integer'
584 || $name eq 'utf8') {
587 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
590 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
594 elsif ($name eq 're') {
596 if ($val eq 'none') {
597 $hint_bits &= ~re::bits(qw/taint eval asciirange/);
603 @names = qw/taint eval asciirange/;
609 @names = split' ',$val;
611 $hint_bits |= re::bits(@names);
614 elsif ($name eq 'warnings') {
615 if ($val eq 'none') {
616 $warning_bits = "\0"x12;
625 @names = split/\s+/, $val;
628 $warning_bits = "\0"x12 if !defined ($warning_bits);
629 $warning_bits |= warnings::bits(@names);
632 elsif ($name eq 'warning_bits') {
633 $warning_bits = $val;
636 elsif ($name eq 'hint_bits') {
641 croak "Unknown pragma type: $name";
645 croak "The ambient_pragmas method expects an even number of args";
648 $self->{'ambient_arybase'} = $arybase;
649 $self->{'ambient_warnings'} = $warning_bits;
650 $self->{'ambient_hints'} = $hint_bits;
655 my($op, $cx, $flags) = @_;
657 Carp::confess("Null op in deparse") if !defined($op)
658 || class($op) eq "NULL";
659 my $meth = "pp_" . $op->name;
661 return $self->$meth($op, $cx, $flags);
663 return $self->$meth($op, $cx);
669 my @lines = split(/\n/, $txt);
674 my $cmd = substr($line, 0, 1);
675 if ($cmd eq "\t" or $cmd eq "\b") {
676 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
677 if ($self->{'use_tabs'}) {
678 $leader = "\t" x ($level / 8) . " " x ($level % 8);
680 $leader = " " x $level;
682 $line = substr($line, 1);
684 if (substr($line, 0, 1) eq "\f") {
685 $line = substr($line, 1); # no indent
687 $line = $leader . $line;
691 return join("\n", @lines);
698 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
699 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
700 local $self->{'curcop'} = $self->{'curcop'};
701 if ($cv->FLAGS & SVf_POK) {
702 $proto = "(". $cv->PV . ") ";
704 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
706 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
707 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
708 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
711 local($self->{'curcv'}) = $cv;
712 local($self->{'curcvlex'});
713 local(@$self{qw'curstash warnings hints'})
714 = @$self{qw'curstash warnings hints'};
716 if (not null $cv->ROOT) {
717 my $lineseq = $cv->ROOT->first;
718 if ($lineseq->name eq "lineseq") {
720 for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
723 $body = $self->lineseq(undef, @ops).";";
724 my $scope_en = $self->find_scope_en($lineseq);
725 if (defined $scope_en) {
726 my $subs = join"", $self->seq_subs($scope_en);
727 $body .= ";\n$subs" if length($subs);
731 $body = $self->deparse($cv->ROOT->first, 0);
735 my $sv = $cv->const_sv;
737 # uh-oh. inlinable sub... format it differently
738 return $proto . "{ " . const($sv) . " }\n";
739 } else { # XSUB? (or just a declaration)
743 return $proto ."{\n\t$body\n\b}" ."\n";
750 local($self->{'curcv'}) = $form;
751 local($self->{'curcvlex'});
752 local(@$self{qw'curstash warnings hints'})
753 = @$self{'curstash warnings hints'};
754 my $op = $form->ROOT;
756 $op = $op->first->first; # skip leavewrite, lineseq
757 while (not null $op) {
758 $op = $op->sibling; # skip nextstate
760 $kid = $op->first->sibling; # skip pushmark
761 push @text, "\f".$self->const_sv($kid)->PV;
762 $kid = $kid->sibling;
763 for (; not null $kid; $kid = $kid->sibling) {
764 push @exprs, $self->deparse($kid, 0);
766 push @text, "\f".join(", ", @exprs)."\n" if @exprs;
769 return join("", @text) . "\f.";
774 return $op->name eq "leave" || $op->name eq "scope"
775 || $op->name eq "lineseq"
776 || ($op->name eq "null" && class($op) eq "UNOP"
777 && (is_scope($op->first) || $op->first->name eq "enter"));
781 my $name = $_[0]->name;
782 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
785 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
787 return (!null($op) and null($op->sibling)
788 and $op->name eq "null" and class($op) eq "UNOP"
789 and (($op->first->name =~ /^(and|or)$/
790 and $op->first->first->sibling->name eq "lineseq")
791 or ($op->first->name eq "lineseq"
792 and not null $op->first->first->sibling
793 and $op->first->first->sibling->name eq "unstack")
799 return ($op->name eq "rv2sv" or
800 $op->name eq "padsv" or
801 $op->name eq "gv" or # only in array/hash constructs
802 $op->flags & OPf_KIDS && !null($op->first)
803 && $op->first->name eq "gvsv");
808 my($text, $cx, $prec) = @_;
809 if ($prec < $cx # unary ops nest just fine
810 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
811 or $self->{'parens'})
814 # In a unop, let parent reuse our parens; see maybe_parens_unop
815 $text = "\cS" . $text if $cx == 16;
822 # same as above, but get around the `if it looks like a function' rule
823 sub maybe_parens_unop {
825 my($name, $kid, $cx) = @_;
826 if ($cx > 16 or $self->{'parens'}) {
827 $kid = $self->deparse($kid, 1);
828 if ($name eq "umask" && $kid =~ /^\d+$/) {
829 $kid = sprintf("%#o", $kid);
831 return "$name($kid)";
833 $kid = $self->deparse($kid, 16);
834 if ($name eq "umask" && $kid =~ /^\d+$/) {
835 $kid = sprintf("%#o", $kid);
837 if (substr($kid, 0, 1) eq "\cS") {
839 return $name . substr($kid, 1);
840 } elsif (substr($kid, 0, 1) eq "(") {
841 # avoid looks-like-a-function trap with extra parens
842 # (`+' can lead to ambiguities)
843 return "$name(" . $kid . ")";
850 sub maybe_parens_func {
852 my($func, $text, $cx, $prec) = @_;
853 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
854 return "$func($text)";
856 return "$func $text";
862 my($op, $cx, $text) = @_;
863 my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
864 if ($op->private & (OPpLVAL_INTRO|$our_intro)
865 and not $self->{'avoid_local'}{$$op}) {
866 my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
867 if (want_scalar($op)) {
868 return "$our_local $text";
870 return $self->maybe_parens_func("$our_local", $text, $cx, 16);
879 my($op, $cx, $func, @args) = @_;
880 if ($op->private & OPpTARGET_MY) {
881 my $var = $self->padname($op->targ);
882 my $val = $func->($self, $op, 7, @args);
883 return $self->maybe_parens("$var = $val", $cx, 7);
885 return $func->($self, $op, $cx, @args);
892 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
897 my($op, $cx, $text) = @_;
898 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
899 if (want_scalar($op)) {
902 return $self->maybe_parens_func("my", $text, $cx, 16);
909 # The following OPs don't have functions:
911 # pp_padany -- does not exist after parsing
912 # pp_rcatline -- does not exist
914 sub pp_enter { # see also leave
915 cluck "unexpected OP_ENTER";
919 sub pp_pushmark { # see also list
920 cluck "unexpected OP_PUSHMARK";
924 sub pp_leavesub { # see also deparse_sub
925 cluck "unexpected OP_LEAVESUB";
929 sub pp_leavewrite { # see also deparse_format
930 cluck "unexpected OP_LEAVEWRITE";
934 sub pp_method { # see also entersub
935 cluck "unexpected OP_METHOD";
939 sub pp_regcmaybe { # see also regcomp
940 cluck "unexpected OP_REGCMAYBE";
944 sub pp_regcreset { # see also regcomp
945 cluck "unexpected OP_REGCRESET";
949 sub pp_substcont { # see also subst
950 cluck "unexpected OP_SUBSTCONT";
954 sub pp_grepstart { # see also grepwhile
955 cluck "unexpected OP_GREPSTART";
959 sub pp_mapstart { # see also mapwhile
960 cluck "unexpected OP_MAPSTART";
964 sub pp_method_named {
965 cluck "unexpected OP_METHOD_NAMED";
969 sub pp_flip { # see also flop
970 cluck "unexpected OP_FLIP";
974 sub pp_iter { # see also leaveloop
975 cluck "unexpected OP_ITER";
979 sub pp_enteriter { # see also leaveloop
980 cluck "unexpected OP_ENTERITER";
984 sub pp_enterloop { # see also leaveloop
985 cluck "unexpected OP_ENTERLOOP";
989 sub pp_leaveeval { # see also entereval
990 cluck "unexpected OP_LEAVEEVAL";
994 sub pp_entertry { # see also leavetry
995 cluck "unexpected OP_ENTERTRY";
999 # $root should be the op which represents the root of whatever
1000 # we're sequencing here. If it's undefined, then we don't append
1001 # any subroutine declarations to the deparsed ops, otherwise we
1002 # append appropriate declarations.
1004 my($self, $root, @ops) = @_;
1007 my $out_cop = $self->{'curcop'};
1008 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1010 if (defined $root) {
1011 $limit_seq = $out_seq;
1012 my $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
1013 $limit_seq = $nseq if !defined($limit_seq)
1014 or defined($nseq) && $nseq < $limit_seq;
1016 $limit_seq = $self->{'limit_seq'}
1017 if defined($self->{'limit_seq'})
1018 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1019 local $self->{'limit_seq'} = $limit_seq;
1020 for (my $i = 0; $i < @ops; $i++) {
1022 if (is_state $ops[$i]) {
1023 $expr = $self->deparse($ops[$i], 0);
1030 if (!is_state $ops[$i] and (my $ls = $ops[$i+1]) and
1031 !null($ops[$i+1]) and $ops[$i+1]->name eq "lineseq")
1033 if ($ls->first && !null($ls->first) && is_state($ls->first)
1034 && (my $sib = $ls->first->sibling)) {
1035 if (!null($sib) && $sib->name eq "leaveloop") {
1036 push @exprs, $expr . $self->for_loop($ops[$i], 0);
1042 $expr .= $self->deparse($ops[$i], 0, (@ops != 1));
1043 $expr =~ s/;\n?\z//;
1046 my $body = join(";\n", grep {length} @exprs);
1048 if (defined $root && defined $limit_seq) {
1049 $subs = join "\n", $self->seq_subs($limit_seq);
1051 return join(";\n", grep {length} $body, $subs);
1055 my($real_block, $self, $op, $cx, $flags) = @_;
1059 local(@$self{qw'curstash warnings hints'})
1060 = @$self{qw'curstash warnings hints'} if $real_block;
1062 $kid = $op->first->sibling; # skip enter
1063 if (is_miniwhile($kid)) {
1064 my $top = $kid->first;
1065 my $name = $top->name;
1066 if ($name eq "and") {
1068 } elsif ($name eq "or") {
1070 } else { # no conditional -> while 1 or until 0
1071 return $self->deparse($top->first, 1) . " while 1";
1073 my $cond = $top->first;
1074 my $body = $cond->sibling->first; # skip lineseq
1075 $cond = $self->deparse($cond, 1);
1076 $body = $self->deparse($body, 1);
1077 return "$body $name $cond";
1082 for (; !null($kid); $kid = $kid->sibling) {
1085 if ($flags || $cx > 0) { # inside an expression, (a do {} while for lineseq)
1086 return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
1088 my $lineseq = $self->lineseq($op, @kids);
1089 return (length ($lineseq) ? "$lineseq;" : "");
1093 sub pp_scope { scopeop(0, @_); }
1094 sub pp_lineseq { scopeop(0, @_); }
1095 sub pp_leave { scopeop(1, @_); }
1097 # The BEGIN {} is used here because otherwise this code isn't executed
1098 # when you run B::Deparse on itself.
1100 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1101 "ENV", "ARGV", "ARGVOUT", "_"); }
1106 Carp::confess() if $gv->isa("B::CV");
1107 my $stash = $gv->STASH->NAME;
1108 my $name = $gv->SAFENAME;
1109 if ($stash eq $self->{'curstash'} or $globalnames{$name}
1110 or $name =~ /^[^A-Za-z_]/)
1114 $stash = $stash . "::";
1116 if ($name =~ /^\^../) {
1117 $name = "{$name}"; # ${^WARNING_BITS} etc
1119 return $stash . $name;
1122 # Return the name to use for a stash variable.
1123 # If a lexical with the same name is in scope, it may need to be
1125 sub stash_variable {
1126 my ($self, $prefix, $name) = @_;
1128 return "$prefix$name" if $name =~ /::/;
1130 unless ($prefix eq '$' || $prefix eq '@' ||
1131 $prefix eq '%' || $prefix eq '$#') {
1132 return "$prefix$name";
1135 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1136 return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
1137 return "$prefix$name";
1141 my ($self, $name) = @_;
1142 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1144 return 0 if !defined($self->{'curcop'});
1145 my $seq = $self->{'curcop'}->cop_seq;
1146 return 0 if !exists $self->{'curcvlex'}{$name};
1147 for my $a (@{$self->{'curcvlex'}{$name}}) {
1148 my ($st, $en) = @$a;
1149 return 1 if $seq > $st && $seq <= $en;
1154 sub populate_curcvlex {
1156 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1157 my @padlist = $cv->PADLIST->ARRAY;
1158 my @ns = $padlist[0]->ARRAY;
1160 for (my $i=0; $i<@ns; ++$i) {
1161 next if class($ns[$i]) eq "SPECIAL";
1162 next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars
1163 if (class($ns[$i]) eq "PV") {
1164 # Probably that pesky lexical @_
1167 my $name = $ns[$i]->PVX;
1168 my $seq_st = $ns[$i]->NVX;
1169 my $seq_en = int($ns[$i]->IVX);
1171 push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
1176 sub find_scope_st { ((find_scope(@_))[0]); }
1177 sub find_scope_en { ((find_scope(@_))[1]); }
1179 # Recurses down the tree, looking for pad variable introductions and COPs
1181 my ($self, $op, $scope_st, $scope_en) = @_;
1182 Carp::cluck() if !defined $op;
1183 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1185 for (my $o=$op->first; $$o; $o=$o->sibling) {
1186 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1187 my $s = int($self->padname_sv($o->targ)->NVX);
1188 my $e = $self->padname_sv($o->targ)->IVX;
1189 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1190 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1192 elsif (is_state($o)) {
1193 my $c = $o->cop_seq;
1194 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1195 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1197 elsif ($o->flags & OPf_KIDS) {
1198 ($scope_st, $scope_en) =
1199 $self->find_scope($o, $scope_st, $scope_en)
1203 return ($scope_st, $scope_en);
1206 # Returns a list of subs which should be inserted before the COP
1208 my ($self, $op, $out_seq) = @_;
1209 my $seq = $op->cop_seq;
1210 # If we have nephews, then our sequence number indicates
1211 # the cop_seq of the end of some sort of scope.
1212 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1213 and my $nseq = $self->find_scope_st($op->sibling) ) {
1216 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1217 return $self->seq_subs($seq);
1221 my ($self, $seq) = @_;
1223 #push @text, "# ($seq)\n";
1225 return "" if !defined $seq;
1226 while (scalar(@{$self->{'subs_todo'}})
1227 and $seq > $self->{'subs_todo'}[0][0]) {
1228 push @text, $self->next_todo;
1233 # Notice how subs and formats are inserted between statements here;
1234 # also $[ assignments and pragmas.
1238 $self->{'curcop'} = $op;
1240 push @text, $self->cop_subs($op);
1241 push @text, $op->label . ": " if $op->label;
1242 my $stash = $op->stashpv;
1243 if ($stash ne $self->{'curstash'}) {
1244 push @text, "package $stash;\n";
1245 $self->{'curstash'} = $stash;
1247 if ($self->{'linenums'}) {
1248 push @text, "\f#line " . $op->line .
1249 ' "' . $op->file, qq'"\n';
1252 if ($self->{'arybase'} != $op->arybase) {
1253 push @text, '$[ = '. $op->arybase .";\n";
1254 $self->{'arybase'} = $op->arybase;
1257 my $warnings = $op->warnings;
1259 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1260 $warning_bits = $warnings::Bits{"all"};
1262 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1263 $warning_bits = "\0"x12;
1265 elsif ($warnings->isa("B::SPECIAL")) {
1266 $warning_bits = undef;
1269 $warning_bits = $warnings->PV & WARN_MASK;
1272 if (defined ($warning_bits) and
1273 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1274 push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1275 $self->{'warnings'} = $warning_bits;
1278 if ($self->{'hints'} != $op->private) {
1279 push @text, declare_hints($self->{'hints'}, $op->private);
1280 $self->{'hints'} = $op->private;
1283 return join("", @text);
1286 sub declare_warnings {
1287 my ($from, $to) = @_;
1288 if (($to & WARN_MASK) eq warnings::bits("all")) {
1289 return "use warnings;\n";
1291 elsif (($to & WARN_MASK) eq "\0"x length($to)) {
1292 return "no warnings;\n";
1294 return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n";
1298 my ($from, $to) = @_;
1299 my $use = $to & ~$from;
1300 my $no = $from & ~$to;
1302 for my $pragma (hint_pragmas($use)) {
1303 $decls .= "use $pragma;\n";
1305 for my $pragma (hint_pragmas($no)) {
1306 $decls .= "no $pragma;\n";
1314 push @pragmas, "integer" if $bits & 0x1;
1315 push @pragmas, "strict 'refs'" if $bits & 0x2;
1316 push @pragmas, "bytes" if $bits & 0x8;
1320 sub pp_dbstate { pp_nextstate(@_) }
1321 sub pp_setstate { pp_nextstate(@_) }
1323 sub pp_unstack { return "" } # see also leaveloop
1327 my($op, $cx, $name) = @_;
1333 my($op, $cx, $name) = @_;
1341 sub pp_wantarray { baseop(@_, "wantarray") }
1342 sub pp_fork { baseop(@_, "fork") }
1343 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1344 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1345 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1346 sub pp_tms { baseop(@_, "times") }
1347 sub pp_ghostent { baseop(@_, "gethostent") }
1348 sub pp_gnetent { baseop(@_, "getnetent") }
1349 sub pp_gprotoent { baseop(@_, "getprotoent") }
1350 sub pp_gservent { baseop(@_, "getservent") }
1351 sub pp_ehostent { baseop(@_, "endhostent") }
1352 sub pp_enetent { baseop(@_, "endnetent") }
1353 sub pp_eprotoent { baseop(@_, "endprotoent") }
1354 sub pp_eservent { baseop(@_, "endservent") }
1355 sub pp_gpwent { baseop(@_, "getpwent") }
1356 sub pp_spwent { baseop(@_, "setpwent") }
1357 sub pp_epwent { baseop(@_, "endpwent") }
1358 sub pp_ggrent { baseop(@_, "getgrent") }
1359 sub pp_sgrent { baseop(@_, "setgrent") }
1360 sub pp_egrent { baseop(@_, "endgrent") }
1361 sub pp_getlogin { baseop(@_, "getlogin") }
1363 sub POSTFIX () { 1 }
1365 # I couldn't think of a good short name, but this is the category of
1366 # symbolic unary operators with interesting precedence
1370 my($op, $cx, $name, $prec, $flags) = (@_, 0);
1371 my $kid = $op->first;
1372 $kid = $self->deparse($kid, $prec);
1373 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1377 sub pp_preinc { pfixop(@_, "++", 23) }
1378 sub pp_predec { pfixop(@_, "--", 23) }
1379 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1380 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1381 sub pp_i_preinc { pfixop(@_, "++", 23) }
1382 sub pp_i_predec { pfixop(@_, "--", 23) }
1383 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1384 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1385 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1387 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1391 if ($op->first->name =~ /^(i_)?negate$/) {
1393 $self->pfixop($op, $cx, "-", 21.5);
1395 $self->pfixop($op, $cx, "-", 21);
1398 sub pp_i_negate { pp_negate(@_) }
1404 $self->pfixop($op, $cx, "not ", 4);
1406 $self->pfixop($op, $cx, "!", 21);
1412 my($op, $cx, $name) = @_;
1414 if ($op->flags & OPf_KIDS) {
1416 if (defined prototype("CORE::$name")
1417 && prototype("CORE::$name") =~ /^;?\*/
1418 && $kid->name eq "rv2gv") {
1422 return $self->maybe_parens_unop($name, $kid, $cx);
1424 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1428 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1429 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1430 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1431 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1432 sub pp_defined { unop(@_, "defined") }
1433 sub pp_undef { unop(@_, "undef") }
1434 sub pp_study { unop(@_, "study") }
1435 sub pp_ref { unop(@_, "ref") }
1436 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1438 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1439 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1440 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1441 sub pp_srand { unop(@_, "srand") }
1442 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1443 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1444 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1445 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1446 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1447 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1448 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1450 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1451 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1452 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1454 sub pp_each { unop(@_, "each") }
1455 sub pp_values { unop(@_, "values") }
1456 sub pp_keys { unop(@_, "keys") }
1457 sub pp_pop { unop(@_, "pop") }
1458 sub pp_shift { unop(@_, "shift") }
1460 sub pp_caller { unop(@_, "caller") }
1461 sub pp_reset { unop(@_, "reset") }
1462 sub pp_exit { unop(@_, "exit") }
1463 sub pp_prototype { unop(@_, "prototype") }
1465 sub pp_close { unop(@_, "close") }
1466 sub pp_fileno { unop(@_, "fileno") }
1467 sub pp_umask { unop(@_, "umask") }
1468 sub pp_untie { unop(@_, "untie") }
1469 sub pp_tied { unop(@_, "tied") }
1470 sub pp_dbmclose { unop(@_, "dbmclose") }
1471 sub pp_getc { unop(@_, "getc") }
1472 sub pp_eof { unop(@_, "eof") }
1473 sub pp_tell { unop(@_, "tell") }
1474 sub pp_getsockname { unop(@_, "getsockname") }
1475 sub pp_getpeername { unop(@_, "getpeername") }
1477 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1478 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1479 sub pp_readlink { unop(@_, "readlink") }
1480 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1481 sub pp_readdir { unop(@_, "readdir") }
1482 sub pp_telldir { unop(@_, "telldir") }
1483 sub pp_rewinddir { unop(@_, "rewinddir") }
1484 sub pp_closedir { unop(@_, "closedir") }
1485 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1486 sub pp_localtime { unop(@_, "localtime") }
1487 sub pp_gmtime { unop(@_, "gmtime") }
1488 sub pp_alarm { unop(@_, "alarm") }
1489 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1491 sub pp_dofile { unop(@_, "do") }
1492 sub pp_entereval { unop(@_, "eval") }
1494 sub pp_ghbyname { unop(@_, "gethostbyname") }
1495 sub pp_gnbyname { unop(@_, "getnetbyname") }
1496 sub pp_gpbyname { unop(@_, "getprotobyname") }
1497 sub pp_shostent { unop(@_, "sethostent") }
1498 sub pp_snetent { unop(@_, "setnetent") }
1499 sub pp_sprotoent { unop(@_, "setprotoent") }
1500 sub pp_sservent { unop(@_, "setservent") }
1501 sub pp_gpwnam { unop(@_, "getpwnam") }
1502 sub pp_gpwuid { unop(@_, "getpwuid") }
1503 sub pp_ggrnam { unop(@_, "getgrnam") }
1504 sub pp_ggrgid { unop(@_, "getgrgid") }
1506 sub pp_lock { unop(@_, "lock") }
1512 if ($op->private & OPpEXISTS_SUB) {
1513 # Checking for the existence of a subroutine
1514 return $self->maybe_parens_func("exists",
1515 $self->pp_rv2cv($op->first, 16), $cx, 16);
1517 if ($op->flags & OPf_SPECIAL) {
1518 # Array element, not hash element
1519 return $self->maybe_parens_func("exists",
1520 $self->pp_aelem($op->first, 16), $cx, 16);
1522 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1530 if ($op->private & OPpSLICE) {
1531 if ($op->flags & OPf_SPECIAL) {
1532 # Deleting from an array, not a hash
1533 return $self->maybe_parens_func("delete",
1534 $self->pp_aslice($op->first, 16),
1537 return $self->maybe_parens_func("delete",
1538 $self->pp_hslice($op->first, 16),
1541 if ($op->flags & OPf_SPECIAL) {
1542 # Deleting from an array, not a hash
1543 return $self->maybe_parens_func("delete",
1544 $self->pp_aelem($op->first, 16),
1547 return $self->maybe_parens_func("delete",
1548 $self->pp_helem($op->first, 16),
1556 if (class($op) eq "UNOP" and $op->first->name eq "const"
1557 and $op->first->private & OPpCONST_BARE)
1559 my $name = $self->const_sv($op->first)->PV;
1562 return "require $name";
1564 $self->unop($op, $cx, "require");
1571 my $kid = $op->first;
1572 if (not null $kid->sibling) {
1573 # XXX Was a here-doc
1574 return $self->dquote($op);
1576 $self->unop(@_, "scalar");
1583 #cluck "curcv was undef" unless $self->{curcv};
1584 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1590 my $kid = $op->first;
1591 if ($kid->name eq "null") {
1593 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1594 my($pre, $post) = @{{"anonlist" => ["[","]"],
1595 "anonhash" => ["{","}"]}->{$kid->name}};
1597 $kid = $kid->first->sibling; # skip pushmark
1598 for (; !null($kid); $kid = $kid->sibling) {
1599 $expr = $self->deparse($kid, 6);
1602 return $pre . join(", ", @exprs) . $post;
1603 } elsif (!null($kid->sibling) and
1604 $kid->sibling->name eq "anoncode") {
1606 $self->deparse_sub($self->padval($kid->sibling->targ));
1607 } elsif ($kid->name eq "pushmark") {
1608 my $sib_name = $kid->sibling->name;
1609 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1610 and not $kid->sibling->flags & OPf_REF)
1612 # The @a in \(@a) isn't in ref context, but only when the
1614 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1615 } elsif ($sib_name eq 'entersub') {
1616 my $text = $self->deparse($kid->sibling, 1);
1617 # Always show parens for \(&func()), but only with -p otherwise
1618 $text = "($text)" if $self->{'parens'}
1619 or $kid->sibling->private & OPpENTERSUB_AMPER;
1624 $self->pfixop($op, $cx, "\\", 20);
1627 sub pp_srefgen { pp_refgen(@_) }
1632 my $kid = $op->first;
1633 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1634 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
1635 return $self->unop($op, $cx, "readline");
1638 # Unary operators that can occur as pseudo-listops inside double quotes
1641 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1643 if ($op->flags & OPf_KIDS) {
1645 # If there's more than one kid, the first is an ex-pushmark.
1646 $kid = $kid->sibling if not null $kid->sibling;
1647 return $self->maybe_parens_unop($name, $kid, $cx);
1649 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1653 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1654 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1655 sub pp_uc { dq_unop(@_, "uc") }
1656 sub pp_lc { dq_unop(@_, "lc") }
1657 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1661 my ($op, $cx, $name) = @_;
1662 if (class($op) eq "PVOP") {
1663 return "$name " . $op->pv;
1664 } elsif (class($op) eq "OP") {
1666 } elsif (class($op) eq "UNOP") {
1667 # Note -- loop exits are actually exempt from the
1668 # looks-like-a-func rule, but a few extra parens won't hurt
1669 return $self->maybe_parens_unop($name, $op->first, $cx);
1673 sub pp_last { loopex(@_, "last") }
1674 sub pp_next { loopex(@_, "next") }
1675 sub pp_redo { loopex(@_, "redo") }
1676 sub pp_goto { loopex(@_, "goto") }
1677 sub pp_dump { loopex(@_, "dump") }
1681 my($op, $cx, $name) = @_;
1682 if (class($op) eq "UNOP") {
1683 # Genuine `-X' filetests are exempt from the LLAFR, but not
1684 # l?stat(); for the sake of clarity, give'em all parens
1685 return $self->maybe_parens_unop($name, $op->first, $cx);
1686 } elsif (class($op) eq "SVOP") {
1687 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1688 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1693 sub pp_lstat { ftst(@_, "lstat") }
1694 sub pp_stat { ftst(@_, "stat") }
1695 sub pp_ftrread { ftst(@_, "-R") }
1696 sub pp_ftrwrite { ftst(@_, "-W") }
1697 sub pp_ftrexec { ftst(@_, "-X") }
1698 sub pp_fteread { ftst(@_, "-r") }
1699 sub pp_ftewrite { ftst(@_, "-w") }
1700 sub pp_fteexec { ftst(@_, "-x") }
1701 sub pp_ftis { ftst(@_, "-e") }
1702 sub pp_fteowned { ftst(@_, "-O") }
1703 sub pp_ftrowned { ftst(@_, "-o") }
1704 sub pp_ftzero { ftst(@_, "-z") }
1705 sub pp_ftsize { ftst(@_, "-s") }
1706 sub pp_ftmtime { ftst(@_, "-M") }
1707 sub pp_ftatime { ftst(@_, "-A") }
1708 sub pp_ftctime { ftst(@_, "-C") }
1709 sub pp_ftsock { ftst(@_, "-S") }
1710 sub pp_ftchr { ftst(@_, "-c") }
1711 sub pp_ftblk { ftst(@_, "-b") }
1712 sub pp_ftfile { ftst(@_, "-f") }
1713 sub pp_ftdir { ftst(@_, "-d") }
1714 sub pp_ftpipe { ftst(@_, "-p") }
1715 sub pp_ftlink { ftst(@_, "-l") }
1716 sub pp_ftsuid { ftst(@_, "-u") }
1717 sub pp_ftsgid { ftst(@_, "-g") }
1718 sub pp_ftsvtx { ftst(@_, "-k") }
1719 sub pp_fttty { ftst(@_, "-t") }
1720 sub pp_fttext { ftst(@_, "-T") }
1721 sub pp_ftbinary { ftst(@_, "-B") }
1723 sub SWAP_CHILDREN () { 1 }
1724 sub ASSIGN () { 2 } # has OP= variant
1725 sub LIST_CONTEXT () { 4 } # Assignment is in list context
1731 my $name = $op->name;
1732 if ($name eq "concat" and $op->first->name eq "concat") {
1733 # avoid spurious `=' -- see comment in pp_concat
1736 if ($name eq "null" and class($op) eq "UNOP"
1737 and $op->first->name =~ /^(and|x?or)$/
1738 and null $op->first->sibling)
1740 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1741 # with a null that's used as the common end point of the two
1742 # flows of control. For precedence purposes, ignore it.
1743 # (COND_EXPRs have these too, but we don't bother with
1744 # their associativity).
1745 return assoc_class($op->first);
1747 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1750 # Left associative operators, like `+', for which
1751 # $a + $b + $c is equivalent to ($a + $b) + $c
1754 %left = ('multiply' => 19, 'i_multiply' => 19,
1755 'divide' => 19, 'i_divide' => 19,
1756 'modulo' => 19, 'i_modulo' => 19,
1758 'add' => 18, 'i_add' => 18,
1759 'subtract' => 18, 'i_subtract' => 18,
1761 'left_shift' => 17, 'right_shift' => 17,
1763 'bit_or' => 12, 'bit_xor' => 12,
1765 'or' => 2, 'xor' => 2,
1769 sub deparse_binop_left {
1771 my($op, $left, $prec) = @_;
1772 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1773 and $left{assoc_class($op)} == $left{assoc_class($left)})
1775 return $self->deparse($left, $prec - .00001);
1777 return $self->deparse($left, $prec);
1781 # Right associative operators, like `=', for which
1782 # $a = $b = $c is equivalent to $a = ($b = $c)
1785 %right = ('pow' => 22,
1786 'sassign=' => 7, 'aassign=' => 7,
1787 'multiply=' => 7, 'i_multiply=' => 7,
1788 'divide=' => 7, 'i_divide=' => 7,
1789 'modulo=' => 7, 'i_modulo=' => 7,
1791 'add=' => 7, 'i_add=' => 7,
1792 'subtract=' => 7, 'i_subtract=' => 7,
1794 'left_shift=' => 7, 'right_shift=' => 7,
1796 'bit_or=' => 7, 'bit_xor=' => 7,
1802 sub deparse_binop_right {
1804 my($op, $right, $prec) = @_;
1805 if ($right{assoc_class($op)} && $right{assoc_class($right)}
1806 and $right{assoc_class($op)} == $right{assoc_class($right)})
1808 return $self->deparse($right, $prec - .00001);
1810 return $self->deparse($right, $prec);
1816 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1817 my $left = $op->first;
1818 my $right = $op->last;
1820 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1824 if ($flags & SWAP_CHILDREN) {
1825 ($left, $right) = ($right, $left);
1827 $left = $self->deparse_binop_left($op, $left, $prec);
1828 $left = "($left)" if $flags & LIST_CONTEXT
1829 && $left !~ /^(my|our|local|)[\@\(]/;
1830 $right = $self->deparse_binop_right($op, $right, $prec);
1831 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1834 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1835 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1836 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1837 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1838 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1839 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1840 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1841 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1842 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1843 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1844 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1846 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1847 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1848 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1849 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1850 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1852 sub pp_eq { binop(@_, "==", 14) }
1853 sub pp_ne { binop(@_, "!=", 14) }
1854 sub pp_lt { binop(@_, "<", 15) }
1855 sub pp_gt { binop(@_, ">", 15) }
1856 sub pp_ge { binop(@_, ">=", 15) }
1857 sub pp_le { binop(@_, "<=", 15) }
1858 sub pp_ncmp { binop(@_, "<=>", 14) }
1859 sub pp_i_eq { binop(@_, "==", 14) }
1860 sub pp_i_ne { binop(@_, "!=", 14) }
1861 sub pp_i_lt { binop(@_, "<", 15) }
1862 sub pp_i_gt { binop(@_, ">", 15) }
1863 sub pp_i_ge { binop(@_, ">=", 15) }
1864 sub pp_i_le { binop(@_, "<=", 15) }
1865 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1867 sub pp_seq { binop(@_, "eq", 14) }
1868 sub pp_sne { binop(@_, "ne", 14) }
1869 sub pp_slt { binop(@_, "lt", 15) }
1870 sub pp_sgt { binop(@_, "gt", 15) }
1871 sub pp_sge { binop(@_, "ge", 15) }
1872 sub pp_sle { binop(@_, "le", 15) }
1873 sub pp_scmp { binop(@_, "cmp", 14) }
1875 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1876 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
1878 # `.' is special because concats-of-concats are optimized to save copying
1879 # by making all but the first concat stacked. The effect is as if the
1880 # programmer had written `($a . $b) .= $c', except legal.
1881 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1885 my $left = $op->first;
1886 my $right = $op->last;
1889 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1893 $left = $self->deparse_binop_left($op, $left, $prec);
1894 $right = $self->deparse_binop_right($op, $right, $prec);
1895 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1898 # `x' is weird when the left arg is a list
1902 my $left = $op->first;
1903 my $right = $op->last;
1906 if ($op->flags & OPf_STACKED) {
1910 if (null($right)) { # list repeat; count is inside left-side ex-list
1911 my $kid = $left->first->sibling; # skip pushmark
1913 for (; !null($kid->sibling); $kid = $kid->sibling) {
1914 push @exprs, $self->deparse($kid, 6);
1917 $left = "(" . join(", ", @exprs). ")";
1919 $left = $self->deparse_binop_left($op, $left, $prec);
1921 $right = $self->deparse_binop_right($op, $right, $prec);
1922 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1927 my ($op, $cx, $type) = @_;
1928 my $left = $op->first;
1929 my $right = $left->sibling;
1930 $left = $self->deparse($left, 9);
1931 $right = $self->deparse($right, 9);
1932 return $self->maybe_parens("$left $type $right", $cx, 9);
1938 my $flip = $op->first;
1939 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1940 return $self->range($flip->first, $cx, $type);
1943 # one-line while/until is handled in pp_leave
1947 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1948 my $left = $op->first;
1949 my $right = $op->first->sibling;
1950 if ($cx == 0 and is_scope($right) and $blockname
1951 and $self->{'expand'} < 7)
1953 $left = $self->deparse($left, 1);
1954 $right = $self->deparse($right, 0);
1955 return "$blockname ($left) {\n\t$right\n\b}\cK";
1956 } elsif ($cx == 0 and $blockname and not $self->{'parens'}
1957 and $self->{'expand'} < 7) { # $b if $a
1958 $right = $self->deparse($right, 1);
1959 $left = $self->deparse($left, 1);
1960 return "$right $blockname $left";
1961 } elsif ($cx > $lowprec and $highop) { # $a && $b
1962 $left = $self->deparse_binop_left($op, $left, $highprec);
1963 $right = $self->deparse_binop_right($op, $right, $highprec);
1964 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1965 } else { # $a and $b
1966 $left = $self->deparse_binop_left($op, $left, $lowprec);
1967 $right = $self->deparse_binop_right($op, $right, $lowprec);
1968 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1972 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1973 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1975 # xor is syntactically a logop, but it's really a binop (contrary to
1976 # old versions of opcode.pl). Syntax is what matters here.
1977 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1981 my ($op, $cx, $opname) = @_;
1982 my $left = $op->first;
1983 my $right = $op->first->sibling->first; # skip sassign
1984 $left = $self->deparse($left, 7);
1985 $right = $self->deparse($right, 7);
1986 return $self->maybe_parens("$left $opname $right", $cx, 7);
1989 sub pp_andassign { logassignop(@_, "&&=") }
1990 sub pp_orassign { logassignop(@_, "||=") }
1994 my($op, $cx, $name) = @_;
1996 my $parens = ($cx >= 5) || $self->{'parens'};
1997 my $kid = $op->first->sibling;
1998 return $name if null $kid;
2000 if (defined prototype("CORE::$name")
2001 && prototype("CORE::$name") =~ /^;?\*/
2002 && $kid->name eq "rv2gv") {
2003 $first = $self->deparse($kid->first, 6);
2006 $first = $self->deparse($kid, 6);
2008 if ($name eq "chmod" && $first =~ /^\d+$/) {
2009 $first = sprintf("%#o", $first);
2011 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
2012 push @exprs, $first;
2013 $kid = $kid->sibling;
2014 for (; !null($kid); $kid = $kid->sibling) {
2015 push @exprs, $self->deparse($kid, 6);
2018 return "$name(" . join(", ", @exprs) . ")";
2020 return "$name " . join(", ", @exprs);
2024 sub pp_bless { listop(@_, "bless") }
2025 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
2026 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
2027 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
2028 sub pp_index { maybe_targmy(@_, \&listop, "index") }
2029 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
2030 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
2031 sub pp_formline { listop(@_, "formline") } # see also deparse_format
2032 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
2033 sub pp_unpack { listop(@_, "unpack") }
2034 sub pp_pack { listop(@_, "pack") }
2035 sub pp_join { maybe_targmy(@_, \&listop, "join") }
2036 sub pp_splice { listop(@_, "splice") }
2037 sub pp_push { maybe_targmy(@_, \&listop, "push") }
2038 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
2039 sub pp_reverse { listop(@_, "reverse") }
2040 sub pp_warn { listop(@_, "warn") }
2041 sub pp_die { listop(@_, "die") }
2042 # Actually, return is exempt from the LLAFR (see examples in this very
2043 # module!), but for consistency's sake, ignore that fact
2044 sub pp_return { listop(@_, "return") }
2045 sub pp_open { listop(@_, "open") }
2046 sub pp_pipe_op { listop(@_, "pipe") }
2047 sub pp_tie { listop(@_, "tie") }
2048 sub pp_binmode { listop(@_, "binmode") }
2049 sub pp_dbmopen { listop(@_, "dbmopen") }
2050 sub pp_sselect { listop(@_, "select") }
2051 sub pp_select { listop(@_, "select") }
2052 sub pp_read { listop(@_, "read") }
2053 sub pp_sysopen { listop(@_, "sysopen") }
2054 sub pp_sysseek { listop(@_, "sysseek") }
2055 sub pp_sysread { listop(@_, "sysread") }
2056 sub pp_syswrite { listop(@_, "syswrite") }
2057 sub pp_send { listop(@_, "send") }
2058 sub pp_recv { listop(@_, "recv") }
2059 sub pp_seek { listop(@_, "seek") }
2060 sub pp_fcntl { listop(@_, "fcntl") }
2061 sub pp_ioctl { listop(@_, "ioctl") }
2062 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
2063 sub pp_socket { listop(@_, "socket") }
2064 sub pp_sockpair { listop(@_, "sockpair") }
2065 sub pp_bind { listop(@_, "bind") }
2066 sub pp_connect { listop(@_, "connect") }
2067 sub pp_listen { listop(@_, "listen") }
2068 sub pp_accept { listop(@_, "accept") }
2069 sub pp_shutdown { listop(@_, "shutdown") }
2070 sub pp_gsockopt { listop(@_, "getsockopt") }
2071 sub pp_ssockopt { listop(@_, "setsockopt") }
2072 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
2073 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
2074 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
2075 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
2076 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
2077 sub pp_link { maybe_targmy(@_, \&listop, "link") }
2078 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
2079 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
2080 sub pp_open_dir { listop(@_, "opendir") }
2081 sub pp_seekdir { listop(@_, "seekdir") }
2082 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
2083 sub pp_system { maybe_targmy(@_, \&listop, "system") }
2084 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
2085 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
2086 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
2087 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
2088 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
2089 sub pp_shmget { listop(@_, "shmget") }
2090 sub pp_shmctl { listop(@_, "shmctl") }
2091 sub pp_shmread { listop(@_, "shmread") }
2092 sub pp_shmwrite { listop(@_, "shmwrite") }
2093 sub pp_msgget { listop(@_, "msgget") }
2094 sub pp_msgctl { listop(@_, "msgctl") }
2095 sub pp_msgsnd { listop(@_, "msgsnd") }
2096 sub pp_msgrcv { listop(@_, "msgrcv") }
2097 sub pp_semget { listop(@_, "semget") }
2098 sub pp_semctl { listop(@_, "semctl") }
2099 sub pp_semop { listop(@_, "semop") }
2100 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
2101 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
2102 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
2103 sub pp_gsbyname { listop(@_, "getservbyname") }
2104 sub pp_gsbyport { listop(@_, "getservbyport") }
2105 sub pp_syscall { listop(@_, "syscall") }
2110 my $text = $self->dq($op->first->sibling); # skip pushmark
2111 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
2112 or $text =~ /[<>]/) {
2113 return 'glob(' . single_delim('qq', '"', $text) . ')';
2115 return '<' . $text . '>';
2119 # Truncate is special because OPf_SPECIAL makes a bareword first arg
2120 # be a filehandle. This could probably be better fixed in the core
2121 # by moving the GV lookup into ck_truc.
2127 my $parens = ($cx >= 5) || $self->{'parens'};
2128 my $kid = $op->first->sibling;
2130 if ($op->flags & OPf_SPECIAL) {
2131 # $kid is an OP_CONST
2132 $fh = $self->const_sv($kid)->PV;
2134 $fh = $self->deparse($kid, 6);
2135 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
2137 my $len = $self->deparse($kid->sibling, 6);
2139 return "truncate($fh, $len)";
2141 return "truncate $fh, $len";
2147 my($op, $cx, $name) = @_;
2149 my $kid = $op->first->sibling;
2151 if ($op->flags & OPf_STACKED) {
2153 $indir = $indir->first; # skip rv2gv
2154 if (is_scope($indir)) {
2155 $indir = "{" . $self->deparse($indir, 0) . "}";
2156 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
2157 $indir = $self->const_sv($indir)->PV;
2159 $indir = $self->deparse($indir, 24);
2161 $indir = $indir . " ";
2162 $kid = $kid->sibling;
2164 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
2165 $indir = ($op->private & OPpSORT_REVERSE) ? '{$b <=> $a} '
2168 elsif ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
2169 $indir = '{$b cmp $a} ';
2171 for (; !null($kid); $kid = $kid->sibling) {
2172 $expr = $self->deparse($kid, 6);
2175 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
2179 sub pp_prtf { indirop(@_, "printf") }
2180 sub pp_print { indirop(@_, "print") }
2181 sub pp_sort { indirop(@_, "sort") }
2185 my($op, $cx, $name) = @_;
2187 my $kid = $op->first; # this is the (map|grep)start
2188 $kid = $kid->first->sibling; # skip a pushmark
2189 my $code = $kid->first; # skip a null
2190 if (is_scope $code) {
2191 $code = "{" . $self->deparse($code, 0) . "} ";
2193 $code = $self->deparse($code, 24) . ", ";
2195 $kid = $kid->sibling;
2196 for (; !null($kid); $kid = $kid->sibling) {
2197 $expr = $self->deparse($kid, 6);
2198 push @exprs, $expr if $expr;
2200 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2203 sub pp_mapwhile { mapop(@_, "map") }
2204 sub pp_grepwhile { mapop(@_, "grep") }
2210 my $kid = $op->first->sibling; # skip pushmark
2212 my $local = "either"; # could be local(...), my(...) or our(...)
2213 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2214 # This assumes that no other private flags equal 128, and that
2215 # OPs that store things other than flags in their op_private,
2216 # like OP_AELEMFAST, won't be immediate children of a list.
2218 # OP_ENTERSUB can break this logic, so check for it.
2219 # I suspect that open and exit can too.
2221 if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
2222 or $lop->name eq "undef")
2223 or $lop->name eq "entersub"
2224 or $lop->name eq "exit"
2225 or $lop->name eq "open")
2227 $local = ""; # or not
2230 if ($lop->name =~ /^pad[ash]v$/) { # my()
2231 ($local = "", last) if $local eq "local" || $local eq "our";
2233 } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
2234 && $lop->private & OPpOUR_INTRO
2235 or $lop->name eq "null" && $lop->first->name eq "gvsv"
2236 && $lop->first->private & OPpOUR_INTRO) { # our()
2237 ($local = "", last) if $local eq "my" || $local eq "local";
2239 } elsif ($lop->name ne "undef") { # local()
2240 ($local = "", last) if $local eq "my" || $local eq "our";
2244 $local = "" if $local eq "either"; # no point if it's all undefs
2245 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2246 for (; !null($kid); $kid = $kid->sibling) {
2248 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2253 $self->{'avoid_local'}{$$lop}++;
2254 $expr = $self->deparse($kid, 6);
2255 delete $self->{'avoid_local'}{$$lop};
2257 $expr = $self->deparse($kid, 6);
2262 return "$local(" . join(", ", @exprs) . ")";
2264 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2268 sub is_ifelse_cont {
2270 return ($op->name eq "null" and class($op) eq "UNOP"
2271 and $op->first->name =~ /^(and|cond_expr)$/
2272 and is_scope($op->first->first->sibling));
2278 my $cond = $op->first;
2279 my $true = $cond->sibling;
2280 my $false = $true->sibling;
2281 my $cuddle = $self->{'cuddle'};
2282 unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
2283 (is_scope($false) || is_ifelse_cont($false))
2284 and $self->{'expand'} < 7) {
2285 $cond = $self->deparse($cond, 8);
2286 $true = $self->deparse($true, 8);
2287 $false = $self->deparse($false, 8);
2288 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2291 $cond = $self->deparse($cond, 1);
2292 $true = $self->deparse($true, 0);
2293 my $head = "if ($cond) {\n\t$true\n\b}";
2295 while (!null($false) and is_ifelse_cont($false)) {
2296 my $newop = $false->first;
2297 my $newcond = $newop->first;
2298 my $newtrue = $newcond->sibling;
2299 $false = $newtrue->sibling; # last in chain is OP_AND => no else
2300 $newcond = $self->deparse($newcond, 1);
2301 $newtrue = $self->deparse($newtrue, 0);
2302 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2304 if (!null($false)) {
2305 $false = $cuddle . "else {\n\t" .
2306 $self->deparse($false, 0) . "\n\b}\cK";
2310 return $head . join($cuddle, "", @elsifs) . $false;
2315 my($op, $cx, $init) = @_;
2316 my $enter = $op->first;
2317 my $kid = $enter->sibling;
2318 local(@$self{qw'curstash warnings hints'})
2319 = @$self{qw'curstash warnings hints'};
2324 if ($kid->name eq "lineseq") { # bare or infinite loop
2325 if (is_state $kid->last) { # infinite
2326 $head = "while (1) "; # Can't use for(;;) if there's a continue
2332 } elsif ($enter->name eq "enteriter") { # foreach
2333 my $ary = $enter->first->sibling; # first was pushmark
2334 my $var = $ary->sibling;
2335 if ($enter->flags & OPf_STACKED
2336 and not null $ary->first->sibling->sibling)
2338 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2339 $self->deparse($ary->first->sibling->sibling, 9);
2341 $ary = $self->deparse($ary, 1);
2344 if ($enter->flags & OPf_SPECIAL) { # thread special var
2345 $var = $self->pp_threadsv($enter, 1);
2346 } else { # regular my() variable
2347 $var = $self->pp_padsv($enter, 1);
2348 if ($self->padname_sv($enter->targ)->IVX ==
2349 $kid->first->first->sibling->last->cop_seq)
2351 # If the scope of this variable closes at the last
2352 # statement of the loop, it must have been
2354 $var = "my " . $var;
2357 } elsif ($var->name eq "rv2gv") {
2358 $var = $self->pp_rv2sv($var, 1);
2359 } elsif ($var->name eq "gv") {
2360 $var = "\$" . $self->deparse($var, 1);
2362 $head = "foreach $var ($ary) ";
2363 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2364 } elsif ($kid->name eq "null") { # while/until
2366 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2367 $cond = $self->deparse($kid->first, 1);
2368 $head = "$name ($cond) ";
2369 $body = $kid->first->sibling;
2370 } elsif ($kid->name eq "stub") { # bare and empty
2371 return "{;}"; # {} could be a hashref
2373 # If there isn't a continue block, then the next pointer for the loop
2374 # will point to the unstack, which is kid's penultimate child, except
2375 # in a bare loop, when it will point to the leaveloop. When neither of
2376 # these conditions hold, then the third-to-last child in the continue
2377 # block (or the last in a bare loop).
2378 my $cont_start = $enter->nextop;
2380 if ($$cont_start != $$op && ${$cont_start->sibling} != ${$body->last}) {
2382 $cont = $body->last;
2384 $cont = $body->first;
2385 while (!null($cont->sibling->sibling->sibling)) {
2386 $cont = $cont->sibling;
2389 my $state = $body->first;
2390 my $cuddle = $self->{'cuddle'};
2392 for (; $$state != $$cont; $state = $state->sibling) {
2393 push @states, $state;
2395 $body = $self->lineseq(undef, @states);
2396 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2397 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2400 $cont = $cuddle . "continue {\n\t" .
2401 $self->deparse($cont, 0) . "\n\b}\cK";
2404 return "" if !defined $body;
2406 $head = "for ($init; $cond;) ";
2409 $body = $self->deparse($body, 0);
2411 $body =~ s/;?$/;\n/;
2413 return $head . "{\n\t" . $body . "\b}" . $cont;
2416 sub pp_leaveloop { loop_common(@_, "") }
2421 my $init = $self->deparse($op, 1);
2422 return $self->loop_common($op->sibling->first->sibling, $cx, $init);
2427 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2430 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2431 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2432 BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
2433 BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
2438 if (class($op) eq "OP") {
2440 return $self->{'ex_const'} if $op->targ == OP_CONST;
2441 } elsif ($op->first->name eq "pushmark") {
2442 return $self->pp_list($op, $cx);
2443 } elsif ($op->first->name eq "enter") {
2444 return $self->pp_leave($op, $cx);
2445 } elsif ($op->targ == OP_STRINGIFY) {
2446 return $self->dquote($op, $cx);
2447 } elsif (!null($op->first->sibling) and
2448 $op->first->sibling->name eq "readline" and
2449 $op->first->sibling->flags & OPf_STACKED) {
2450 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2451 . $self->deparse($op->first->sibling, 7),
2453 } elsif (!null($op->first->sibling) and
2454 $op->first->sibling->name eq "trans" and
2455 $op->first->sibling->flags & OPf_STACKED) {
2456 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2457 . $self->deparse($op->first->sibling, 20),
2459 } elsif ($op->flags & OPf_SPECIAL && $cx == 0 && !$op->targ) {
2460 return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
2462 return $self->deparse($op->first, $cx);
2469 return $self->padname_sv($targ)->PVX;
2475 return substr($self->padname($op->targ), 1); # skip $/@/%
2481 return $self->maybe_my($op, $cx, $self->padname($op->targ));
2484 sub pp_padav { pp_padsv(@_) }
2485 sub pp_padhv { pp_padsv(@_) }
2490 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2491 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2492 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2499 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
2505 if (class($op) eq "PADOP") {
2506 return $self->padval($op->padix);
2507 } else { # class($op) eq "SVOP"
2515 my $gv = $self->gv_or_padgv($op);
2516 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2517 $self->gv_name($gv)));
2523 my $gv = $self->gv_or_padgv($op);
2524 return $self->gv_name($gv);
2530 my $gv = $self->gv_or_padgv($op);
2531 my $name = $self->gv_name($gv);
2532 $name = $self->{'curstash'}."::$name"
2533 if $name !~ /::/ && $self->lex_in_scope('@'.$name);
2535 return "\$" . $name . "[" .
2536 ($op->private + $self->{'arybase'}) . "]";
2541 my($op, $cx, $type) = @_;
2543 if (class($op) eq 'NULL' || !$op->can("first")) {
2544 Carp::cluck("Unexpected op in pp_rv2x");
2547 my $kid = $op->first;
2548 my $str = $self->deparse($kid, 0);
2549 return $self->stash_variable($type, $str) if is_scalar($kid);
2550 return $type ."{$str}";
2553 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2554 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2555 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2561 if ($op->first->name eq "padav") {
2562 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2564 return $self->maybe_local($op, $cx,
2565 $self->rv2x($op->first, $cx, '$#'));
2569 # skip down to the old, ex-rv2cv
2571 my ($self, $op, $cx) = @_;
2572 if (!null($op->first) && $op->first->name eq 'null' &&
2573 $op->first->targ eq OP_LIST)
2575 return $self->rv2x($op->first->first->sibling, $cx, "&")
2578 return $self->rv2x($op, $cx, "")
2585 my $kid = $op->first;
2586 if ($kid->name eq "const") { # constant list
2587 my $av = $self->const_sv($kid);
2588 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2590 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2594 sub is_subscriptable {
2596 if ($op->name =~ /^[ahg]elem/) {
2598 } elsif ($op->name eq "entersub") {
2599 my $kid = $op->first;
2600 return 0 unless null $kid->sibling;
2602 $kid = $kid->sibling until null $kid->sibling;
2603 return 0 if is_scope($kid);
2605 return 0 if $kid->name eq "gv";
2606 return 0 if is_scalar($kid);
2607 return is_subscriptable($kid);
2615 my ($op, $cx, $left, $right, $padname) = @_;
2616 my($array, $idx) = ($op->first, $op->first->sibling);
2617 unless ($array->name eq $padname) { # Maybe this has been fixed
2618 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2620 if ($array->name eq $padname) {
2621 $array = $self->padany($array);
2622 } elsif (is_scope($array)) { # ${expr}[0]
2623 $array = "{" . $self->deparse($array, 0) . "}";
2624 } elsif ($array->name eq "gv") {
2625 $array = $self->gv_name($self->gv_or_padgv($array));
2626 if ($array !~ /::/) {
2627 my $prefix = ($left eq '[' ? '@' : '%');
2628 $array = $self->{curstash}.'::'.$array
2629 if $self->lex_in_scope($prefix . $array);
2631 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2632 $array = $self->deparse($array, 24);
2634 # $x[20][3]{hi} or expr->[20]
2635 my $arrow = is_subscriptable($array) ? "" : "->";
2636 return $self->deparse($array, 24) . $arrow .
2637 $left . $self->deparse($idx, 1) . $right;
2639 $idx = $self->deparse($idx, 1);
2641 # Outer parens in an array index will confuse perl
2642 # if we're interpolating in a regular expression, i.e.
2643 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2645 # If $self->{parens}, then an initial '(' will
2646 # definitely be paired with a final ')'. If
2647 # !$self->{parens}, the misleading parens won't
2648 # have been added in the first place.
2650 # [You might think that we could get "(...)...(...)"
2651 # where the initial and final parens do not match
2652 # each other. But we can't, because the above would
2653 # only happen if there's an infix binop between the
2654 # two pairs of parens, and *that* means that the whole
2655 # expression would be parenthesized as well.]
2657 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2659 return "\$" . $array . $left . $idx . $right;
2662 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2663 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2668 my($glob, $part) = ($op->first, $op->last);
2669 $glob = $glob->first; # skip rv2gv
2670 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2671 my $scope = is_scope($glob);
2672 $glob = $self->deparse($glob, 0);
2673 $part = $self->deparse($part, 1);
2674 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2679 my ($op, $cx, $left, $right, $regname, $padname) = @_;
2681 my(@elems, $kid, $array, $list);
2682 if (class($op) eq "LISTOP") {
2684 } else { # ex-hslice inside delete()
2685 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2689 $array = $array->first
2690 if $array->name eq $regname or $array->name eq "null";
2691 if (is_scope($array)) {
2692 $array = "{" . $self->deparse($array, 0) . "}";
2693 } elsif ($array->name eq $padname) {
2694 $array = $self->padany($array);
2696 $array = $self->deparse($array, 24);
2698 $kid = $op->first->sibling; # skip pushmark
2699 if ($kid->name eq "list") {
2700 $kid = $kid->first->sibling; # skip list, pushmark
2701 for (; !null $kid; $kid = $kid->sibling) {
2702 push @elems, $self->deparse($kid, 6);
2704 $list = join(", ", @elems);
2706 $list = $self->deparse($kid, 1);
2708 return "\@" . $array . $left . $list . $right;
2711 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2712 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2717 my $idx = $op->first;
2718 my $list = $op->last;
2720 $list = $self->deparse($list, 1);
2721 $idx = $self->deparse($idx, 1);
2722 return "($list)" . "[$idx]";
2727 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2732 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2738 my $kid = $op->first->sibling; # skip pushmark
2739 my($meth, $obj, @exprs);
2740 if ($kid->name eq "list" and want_list $kid) {
2741 # When an indirect object isn't a bareword but the args are in
2742 # parens, the parens aren't part of the method syntax (the LLAFR
2743 # doesn't apply), but they make a list with OPf_PARENS set that
2744 # doesn't get flattened by the append_elem that adds the method,
2745 # making a (object, arg1, arg2, ...) list where the object
2746 # usually is. This can be distinguished from
2747 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2748 # object) because in the later the list is in scalar context
2749 # as the left side of -> always is, while in the former
2750 # the list is in list context as method arguments always are.
2751 # (Good thing there aren't method prototypes!)
2752 $meth = $kid->sibling;
2753 $kid = $kid->first->sibling; # skip pushmark
2755 $kid = $kid->sibling;
2756 for (; not null $kid; $kid = $kid->sibling) {
2757 push @exprs, $self->deparse($kid, 6);
2761 $kid = $kid->sibling;
2762 for (; !null ($kid->sibling) && $kid->name ne "method_named";
2763 $kid = $kid->sibling) {
2764 push @exprs, $self->deparse($kid, 6);
2768 $obj = $self->deparse($obj, 24);
2769 if ($meth->name eq "method_named") {
2770 $meth = $self->const_sv($meth)->PV;
2772 $meth = $meth->first;
2773 if ($meth->name eq "const") {
2774 # As of 5.005_58, this case is probably obsoleted by the
2775 # method_named case above
2776 $meth = $self->const_sv($meth)->PV; # needs to be bare
2778 $meth = $self->deparse($meth, 1);
2781 my $args = join(", ", @exprs);
2782 $kid = $obj . "->" . $meth;
2784 return $kid . "(" . $args . ")"; # parens mandatory
2790 # returns "&" if the prototype doesn't match the args,
2791 # or ("", $args_after_prototype_demunging) if it does.
2794 my($proto, @args) = @_;
2798 # An unbackslashed @ or % gobbles up the rest of the args
2799 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2801 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2804 return "&" if @args;
2805 } elsif ($chr eq ";") {
2807 } elsif ($chr eq "@" or $chr eq "%") {
2808 push @reals, map($self->deparse($_, 6), @args);
2814 if (want_scalar $arg) {
2815 push @reals, $self->deparse($arg, 6);
2819 } elsif ($chr eq "&") {
2820 if ($arg->name =~ /^(s?refgen|undef)$/) {
2821 push @reals, $self->deparse($arg, 6);
2825 } elsif ($chr eq "*") {
2826 if ($arg->name =~ /^s?refgen$/
2827 and $arg->first->first->name eq "rv2gv")
2829 $real = $arg->first->first; # skip refgen, null
2830 if ($real->first->name eq "gv") {
2831 push @reals, $self->deparse($real, 6);
2833 push @reals, $self->deparse($real->first, 6);
2838 } elsif (substr($chr, 0, 1) eq "\\") {
2839 $chr = substr($chr, 1);
2840 if ($arg->name =~ /^s?refgen$/ and
2841 !null($real = $arg->first) and
2842 ($chr eq "\$" && is_scalar($real->first)
2844 && $real->first->sibling->name
2847 && $real->first->sibling->name
2849 #or ($chr eq "&" # This doesn't work
2850 # && $real->first->name eq "rv2cv")
2852 && $real->first->name eq "rv2gv")))
2854 push @reals, $self->deparse($real, 6);
2861 return "&" if $proto and !$doneok; # too few args and no `;'
2862 return "&" if @args; # too many args
2863 return ("", join ", ", @reals);
2869 return $self->method($op, $cx) unless null $op->first->sibling;
2873 if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
2875 } elsif ($op->private & OPpENTERSUB_AMPER) {
2879 $kid = $kid->first->sibling; # skip ex-list, pushmark
2880 for (; not null $kid->sibling; $kid = $kid->sibling) {
2885 if (is_scope($kid)) {
2887 $kid = "{" . $self->deparse($kid, 0) . "}";
2888 } elsif ($kid->first->name eq "gv") {
2889 my $gv = $self->gv_or_padgv($kid->first);
2890 if (class($gv->CV) ne "SPECIAL") {
2891 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2893 $simple = 1; # only calls of named functions can be prototyped
2894 $kid = $self->deparse($kid, 24);
2895 } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
2897 $kid = $self->deparse($kid, 24);
2900 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2901 $kid = $self->deparse($kid, 24) . $arrow;
2904 # Doesn't matter how many prototypes there are, if
2905 # they haven't happened yet!
2906 my $declared = exists $self->{'subs_declared'}{$kid};
2907 if (!$declared && defined($proto)) {
2908 # Avoid "too early to check prototype" warning
2909 ($amper, $proto) = ('&');
2913 if ($declared and defined $proto and not $amper) {
2914 ($amper, $args) = $self->check_proto($proto, @exprs);
2915 if ($amper eq "&") {
2916 $args = join(", ", map($self->deparse($_, 6), @exprs));
2919 $args = join(", ", map($self->deparse($_, 6), @exprs));
2921 if ($prefix or $amper) {
2922 if ($op->flags & OPf_STACKED) {
2923 return $prefix . $amper . $kid . "(" . $args . ")";
2925 return $prefix . $amper. $kid;
2928 # glob() invocations can be translated into calls of
2929 # CORE::GLOBAL::glob with an second parameter, a number.
2931 if ($kid eq "CORE::GLOBAL::glob") {
2933 $args =~ s/\s*,[^,]+$//;
2936 # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
2937 # so it must have been translated from a keyword call. Translate
2939 $kid =~ s/^CORE::GLOBAL:://;
2942 return "$kid(" . $args . ")";
2943 } elsif (defined $proto and $proto eq "") {
2945 } elsif (defined $proto and $proto eq "\$" and is_scalar($exprs[0])) {
2946 return $self->maybe_parens_func($kid, $args, $cx, 16);
2947 } elsif (defined($proto) && $proto or $simple) {
2948 return $self->maybe_parens_func($kid, $args, $cx, 5);
2950 return "$kid(" . $args . ")";
2955 sub pp_enterwrite { unop(@_, "write") }
2957 # escape things that cause interpolation in double quotes,
2958 # but not character escapes
2961 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
2965 # the same, but treat $|, $), $( and $ at the end of the string differently
2970 # Matches any string which is balanced with respect to {braces}
2990 (\(\?\??\{$bal\}\)) # $4
2996 /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3001 sub re_uninterp_extended {
3003 $str =~ s/^([^#]*)/re_uninterp($1)/emg;
3007 # character escapes, but not delimiters that might need to be escaped
3008 sub escape_str { # ASCII, UTF8
3010 $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3012 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
3018 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
3019 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
3023 sub escape_extended_re {
3025 $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3026 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
3027 $str =~ s/\n/\n\f/g;
3031 # Don't do this for regexen
3034 $str =~ s/\\/\\\\/g;
3038 # Remove backslashes which precede literal control characters,
3039 # to avoid creating ambiguity when we escape the latter.
3043 # the insane complexity here is due to the behaviour of "\c\"
3044 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
3048 sub balanced_delim {
3050 my @str = split //, $str;
3051 my($ar, $open, $close, $fail, $c, $cnt);
3052 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
3053 ($open, $close) = @$ar;
3054 $fail = 0; $cnt = 0;
3058 } elsif ($c eq $close) {
3067 $fail = 1 if $cnt != 0;
3068 return ($open, "$open$str$close") if not $fail;
3074 my($q, $default, $str) = @_;
3075 return "$default$str$default" if $default and index($str, $default) == -1;
3076 my($succeed, $delim);
3077 ($succeed, $str) = balanced_delim($str);
3078 return "$q$str" if $succeed;
3079 for $delim ('/', '"', '#') {
3080 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3083 $str =~ s/$default/\\$default/g;
3084 return "$default$str$default";
3093 if (class($sv) eq "SPECIAL") {
3094 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
3095 } elsif (class($sv) eq "NULL") {
3097 } elsif ($sv->FLAGS & SVf_IOK) {
3098 return $sv->int_value;
3099 } elsif ($sv->FLAGS & SVf_NOK) {
3100 # try the default stringification
3103 # If it's in scientific notation, we might have lost information
3104 return sprintf("%.20e", $sv->NV);
3107 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3108 return "\\(" . const($sv->RV) . ")"; # constant folded
3109 } elsif ($sv->FLAGS & SVf_POK) {
3111 if ($str =~ /[^ -~]/) { # ASCII for non-printing
3112 return single_delim("qq", '"', uninterp escape_str unback $str);
3114 return single_delim("q", "'", unback $str);
3125 # the constant could be in the pad (under useithreads)
3126 $sv = $self->padval($op->targ) unless $$sv;
3133 if ($op->private & OPpCONST_ARYBASE) {
3136 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3137 # return $self->const_sv($op)->PV;
3139 my $sv = $self->const_sv($op);
3140 # return const($sv);
3142 return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
3148 my $type = $op->name;
3149 if ($type eq "const") {
3150 return '$[' if $op->private & OPpCONST_ARYBASE;
3151 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3152 } elsif ($type eq "concat") {
3153 my $first = $self->dq($op->first);
3154 my $last = $self->dq($op->last);
3156 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3157 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3158 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
3159 || ($last =~ /^[{\[\w_]/ &&
3160 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3162 return $first . $last;
3163 } elsif ($type eq "uc") {
3164 return '\U' . $self->dq($op->first->sibling) . '\E';
3165 } elsif ($type eq "lc") {
3166 return '\L' . $self->dq($op->first->sibling) . '\E';
3167 } elsif ($type eq "ucfirst") {
3168 return '\u' . $self->dq($op->first->sibling);
3169 } elsif ($type eq "lcfirst") {
3170 return '\l' . $self->dq($op->first->sibling);
3171 } elsif ($type eq "quotemeta") {
3172 return '\Q' . $self->dq($op->first->sibling) . '\E';
3173 } elsif ($type eq "join") {
3174 return $self->deparse($op->last, 26); # was join($", @ary)
3176 return $self->deparse($op, 26);
3184 return single_delim("qx", '`', $self->dq($op->first->sibling));
3190 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3191 return $self->deparse($kid, $cx) if $self->{'unquote'};
3192 $self->maybe_targmy($kid, $cx,
3193 sub {single_delim("qq", '"', $self->dq($_[1]))});
3196 # OP_STRINGIFY is a listop, but it only ever has one arg
3197 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3199 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3200 # note that tr(from)/to/ is OK, but not tr/from/(to)
3202 my($from, $to) = @_;
3203 my($succeed, $delim);
3204 if ($from !~ m[/] and $to !~ m[/]) {
3205 return "/$from/$to/";
3206 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3207 if (($succeed, $to) = balanced_delim($to) and $succeed) {
3210 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3211 return "$from$delim$to$delim" if index($to, $delim) == -1;
3214 return "$from/$to/";
3217 for $delim ('/', '"', '#') { # note no '
3218 return "$delim$from$delim$to$delim"
3219 if index($to . $from, $delim) == -1;
3221 $from =~ s[/][\\/]g;
3223 return "/$from/$to/";
3227 # Only used by tr///, so backslashes hyphens
3230 if ($n == ord '\\') {
3232 } elsif ($n == ord "-") {
3234 } elsif ($n >= ord(' ') and $n <= ord('~')) {
3236 } elsif ($n == ord "\a") {
3238 } elsif ($n == ord "\b") {
3240 } elsif ($n == ord "\t") {
3242 } elsif ($n == ord "\n") {
3244 } elsif ($n == ord "\e") {
3246 } elsif ($n == ord "\f") {
3248 } elsif ($n == ord "\r") {
3250 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3251 return '\\c' . chr(ord("@") + $n);
3253 # return '\x' . sprintf("%02x", $n);
3254 return '\\' . sprintf("%03o", $n);
3260 my($str, $c, $tr) = ("");
3261 for ($c = 0; $c < @chars; $c++) {
3264 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3265 $chars[$c + 2] == $tr + 2)
3267 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3270 $str .= pchr($chars[$c]);
3276 sub tr_decode_byte {
3277 my($table, $flags) = @_;
3278 my(@table) = unpack("s*", $table);
3279 splice @table, 0x100, 1; # Number of subsequent elements
3280 my($c, $tr, @from, @to, @delfrom, $delhyphen);
3281 if ($table[ord "-"] != -1 and
3282 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3284 $tr = $table[ord "-"];
3285 $table[ord "-"] = -1;
3289 } else { # -2 ==> delete
3293 for ($c = 0; $c < @table; $c++) {
3296 push @from, $c; push @to, $tr;
3297 } elsif ($tr == -2) {
3301 @from = (@from, @delfrom);
3302 if ($flags & OPpTRANS_COMPLEMENT) {
3305 @from{@from} = (1) x @from;
3306 for ($c = 0; $c < 256; $c++) {
3307 push @newfrom, $c unless $from{$c};
3311 unless ($flags & OPpTRANS_DELETE || !@to) {
3312 pop @to while $#to and $to[$#to] == $to[$#to -1];
3315 $from = collapse(@from);
3316 $to = collapse(@to);
3317 $from .= "-" if $delhyphen;
3318 return ($from, $to);
3323 if ($x == ord "-") {
3325 } elsif ($x == ord "\\") {
3332 # XXX This doesn't yet handle all cases correctly either
3334 sub tr_decode_utf8 {
3335 my($swash_hv, $flags) = @_;
3336 my %swash = $swash_hv->ARRAY;
3338 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3339 my $none = $swash{"NONE"}->IV;
3340 my $extra = $none + 1;
3341 my(@from, @delfrom, @to);
3343 foreach $line (split /\n/, $swash{'LIST'}->PV) {
3344 my($min, $max, $result) = split(/\t/, $line);
3351 $result = hex $result;
3352 if ($result == $extra) {
3353 push @delfrom, [$min, $max];
3355 push @from, [$min, $max];
3356 push @to, [$result, $result + $max - $min];
3359 for my $i (0 .. $#from) {
3360 if ($from[$i][0] == ord '-') {
3361 unshift @from, splice(@from, $i, 1);
3362 unshift @to, splice(@to, $i, 1);
3364 } elsif ($from[$i][1] == ord '-') {
3367 unshift @from, ord '-';
3368 unshift @to, ord '-';
3372 for my $i (0 .. $#delfrom) {
3373 if ($delfrom[$i][0] == ord '-') {
3374 push @delfrom, splice(@delfrom, $i, 1);
3376 } elsif ($delfrom[$i][1] == ord '-') {
3378 push @delfrom, ord '-';
3382 if (defined $final and $to[$#to][1] != $final) {
3383 push @to, [$final, $final];
3385 push @from, @delfrom;
3386 if ($flags & OPpTRANS_COMPLEMENT) {
3389 for my $i (0 .. $#from) {
3390 push @newfrom, [$next, $from[$i][0] - 1];
3391 $next = $from[$i][1] + 1;
3394 for my $range (@newfrom) {
3395 if ($range->[0] <= $range->[1]) {
3400 my($from, $to, $diff);
3401 for my $chunk (@from) {
3402 $diff = $chunk->[1] - $chunk->[0];
3404 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3405 } elsif ($diff == 1) {
3406 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3408 $from .= tr_chr($chunk->[0]);
3411 for my $chunk (@to) {
3412 $diff = $chunk->[1] - $chunk->[0];
3414 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3415 } elsif ($diff == 1) {
3416 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3418 $to .= tr_chr($chunk->[0]);
3421 #$final = sprintf("%04x", $final) if defined $final;
3422 #$none = sprintf("%04x", $none) if defined $none;
3423 #$extra = sprintf("%04x", $extra) if defined $extra;
3424 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3425 #print STDERR $swash{'LIST'}->PV;
3426 return (escape_str($from), escape_str($to));
3433 if (class($op) eq "PVOP") {
3434 ($from, $to) = tr_decode_byte($op->pv, $op->private);
3435 } else { # class($op) eq "SVOP"
3436 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3439 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3440 $flags .= "d" if $op->private & OPpTRANS_DELETE;
3441 $to = "" if $from eq $to and $flags eq "";
3442 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3443 return "tr" . double_delim($from, $to) . $flags;
3446 # Like dq(), but different
3449 my ($op, $extended) = @_;
3451 my $type = $op->name;
3452 if ($type eq "const") {
3453 return '$[' if $op->private & OPpCONST_ARYBASE;
3454 my $unbacked = re_unback($self->const_sv($op)->as_string);
3455 return re_uninterp_extended(escape_extended_re($unbacked))
3457 return re_uninterp(escape_str($unbacked));
3458 } elsif ($type eq "concat") {
3459 my $first = $self->re_dq($op->first, $extended);
3460 my $last = $self->re_dq($op->last, $extended);
3462 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3463 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3464 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
3465 || ($last =~ /^[{\[\w_]/ &&
3466 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3468 return $first . $last;
3469 } elsif ($type eq "uc") {
3470 return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
3471 } elsif ($type eq "lc") {
3472 return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
3473 } elsif ($type eq "ucfirst") {
3474 return '\u' . $self->re_dq($op->first->sibling, $extended);
3475 } elsif ($type eq "lcfirst") {
3476 return '\l' . $self->re_dq($op->first->sibling, $extended);
3477 } elsif ($type eq "quotemeta") {
3478 return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
3479 } elsif ($type eq "join") {
3480 return $self->deparse($op->last, 26); # was join($", @ary)
3482 return $self->deparse($op, 26);
3487 my ($self, $op) = @_;
3488 my $type = $op->name;
3490 if ($type eq 'const') {
3493 elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
3494 return $self->pure_string($op->first->sibling);
3496 elsif ($type eq 'join') {
3497 my $join_op = $op->first->sibling; # Skip pushmark
3498 return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
3500 my $gvop = $join_op->first;
3501 return 0 unless $gvop->name eq 'gvsv';
3502 return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
3504 return 0 unless ${$join_op->sibling} eq ${$op->last};
3505 return 0 unless $op->last->name =~ /^(rv2|pad)av$/;
3507 elsif ($type eq 'concat') {
3508 return $self->pure_string($op->first)
3509 && $self->pure_string($op->last);
3511 elsif (is_scalar($op) || $type =~ /^[ah]elem(fast)?$/) {
3523 my($op, $cx, $extended) = @_;
3524 my $kid = $op->first;
3525 $kid = $kid->first if $kid->name eq "regcmaybe";
3526 $kid = $kid->first if $kid->name eq "regcreset";
3527 return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
3528 return ($self->deparse($kid, $cx), 0);
3532 my ($self, $op, $cx) = @_;
3533 return (($self->regcomp($op, $cx, 0))[0]);
3536 # osmic acid -- see osmium tetroxide
3539 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3540 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3541 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3545 my($op, $cx, $name, $delim) = @_;
3546 my $kid = $op->first;
3547 my ($binop, $var, $re) = ("", "", "");
3548 if ($op->flags & OPf_STACKED) {
3550 $var = $self->deparse($kid, 20);
3551 $kid = $kid->sibling;
3554 my $extended = ($op->pmflags & PMf_EXTENDED);
3556 my $unbacked = re_unback($op->precomp);
3558 $re = re_uninterp_extended(escape_extended_re($unbacked));
3560 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3562 } elsif ($kid->name ne 'regcomp') {
3563 Carp::cluck("found ".$kid->name." where regcomp expected");
3565 ($re, $quote) = $self->regcomp($kid, 1, $extended);
3568 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3569 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3570 $flags .= "i" if $op->pmflags & PMf_FOLD;
3571 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3572 $flags .= "o" if $op->pmflags & PMf_KEEP;
3573 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3574 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3575 $flags = $matchwords{$flags} if $matchwords{$flags};
3576 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3580 $re = single_delim($name, $delim, $re);
3582 $re = $re . $flags if $quote;
3584 return $self->maybe_parens("$var =~ $re", $cx, 20);
3590 sub pp_match { matchop(@_, "m", "/") }
3591 sub pp_pushre { matchop(@_, "m", "/") }
3592 sub pp_qr { matchop(@_, "qr", "") }
3597 my($kid, @exprs, $ary, $expr);
3599 if ($ {$kid->pmreplroot}) {
3600 $ary = $self->stash_variable('@', $self->gv_name($kid->pmreplroot));
3602 for (; !null($kid); $kid = $kid->sibling) {
3603 push @exprs, $self->deparse($kid, 6);
3606 # handle special case of split(), and split(" ") that compiles to /\s+/
3608 if ($kid->flags & OPf_SPECIAL
3609 && $exprs[0] eq '/\\s+/'
3610 && $kid->pmflags & PMf_SKIPWHITE ) {
3614 $expr = "split(" . join(", ", @exprs) . ")";
3616 return $self->maybe_parens("$ary = $expr", $cx, 7);
3622 # oxime -- any of various compounds obtained chiefly by the action of
3623 # hydroxylamine on aldehydes and ketones and characterized by the
3624 # bivalent grouping C=NOH [Webster's Tenth]
3627 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3628 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3629 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3630 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3635 my $kid = $op->first;
3636 my($binop, $var, $re, $repl) = ("", "", "", "");
3637 if ($op->flags & OPf_STACKED) {
3639 $var = $self->deparse($kid, 20);
3640 $kid = $kid->sibling;
3643 if (null($op->pmreplroot)) {
3644 $repl = $self->dq($kid);
3645 $kid = $kid->sibling;
3647 $repl = $op->pmreplroot->first; # skip substcont
3648 while ($repl->name eq "entereval") {
3649 $repl = $repl->first;
3652 if ($op->pmflags & PMf_EVAL) {
3653 $repl = $self->deparse($repl, 0);
3655 $repl = $self->dq($repl);
3659 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3661 $re = $self->deparse($kid, 1);
3663 $flags .= "e" if $op->pmflags & PMf_EVAL;
3664 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3665 $flags .= "i" if $op->pmflags & PMf_FOLD;
3666 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3667 $flags .= "o" if $op->pmflags & PMf_KEEP;
3668 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3669 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3670 $flags = $substwords{$flags} if $substwords{$flags};
3672 return $self->maybe_parens("$var =~ s"
3673 . double_delim($re, $repl) . $flags,
3676 return "s". double_delim($re, $repl) . $flags;
3685 B::Deparse - Perl compiler backend to produce perl code
3689 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3690 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3694 B::Deparse is a backend module for the Perl compiler that generates
3695 perl source code, based on the internal compiled structure that perl
3696 itself creates after parsing a program. The output of B::Deparse won't
3697 be exactly the same as the original source, since perl doesn't keep
3698 track of comments or whitespace, and there isn't a one-to-one
3699 correspondence between perl's syntactical constructions and their
3700 compiled form, but it will often be close. When you use the B<-p>
3701 option, the output also includes parentheses even when they are not
3702 required by precedence, which can make it easy to see if perl is
3703 parsing your expressions the way you intended.
3705 Please note that this module is mainly new and untested code and is
3706 still under development, so it may change in the future.
3710 As with all compiler backend options, these must follow directly after
3711 the '-MO=Deparse', separated by a comma but not any white space.
3717 Add '#line' declarations to the output based on the line and file
3718 locations of the original code.
3722 Print extra parentheses. Without this option, B::Deparse includes
3723 parentheses in its output only when they are needed, based on the
3724 structure of your program. With B<-p>, it uses parentheses (almost)
3725 whenever they would be legal. This can be useful if you are used to
3726 LISP, or if you want to see how perl parses your input. If you say
3728 if ($var & 0x7f == 65) {print "Gimme an A!"}
3729 print ($which ? $a : $b), "\n";
3730 $name = $ENV{USER} or "Bob";
3732 C<B::Deparse,-p> will print
3735 print('Gimme an A!')
3737 (print(($which ? $a : $b)), '???');
3738 (($name = $ENV{'USER'}) or '???')
3740 which probably isn't what you intended (the C<'???'> is a sign that
3741 perl optimized away a constant value).
3745 Expand double-quoted strings into the corresponding combinations of
3746 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3749 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3753 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3754 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3756 Note that the expanded form represents the way perl handles such
3757 constructions internally -- this option actually turns off the reverse
3758 translation that B::Deparse usually does. On the other hand, note that
3759 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3760 of $y into a string before doing the assignment.
3764 Normally, B::Deparse deparses the main code of a program, and all the subs
3765 defined in the same file. To include subs defined in other files, pass the
3766 B<-f> option with the filename. You can pass the B<-f> option several times, to
3767 include more than one secondary file. (Most of the time you don't want to
3768 use it at all.) You can also use this option to include subs which are
3769 defined in the scope of a B<#line> directive with two parameters.
3771 =item B<-s>I<LETTERS>
3773 Tweak the style of B::Deparse's output. The letters should follow
3774 directly after the 's', with no space or punctuation. The following
3775 options are available:
3781 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3798 The default is not to cuddle.
3802 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3806 Use tabs for each 8 columns of indent. The default is to use only spaces.
3807 For instance, if the style options are B<-si4T>, a line that's indented
3808 3 times will be preceded by one tab and four spaces; if the options were
3809 B<-si8T>, the same line would be preceded by three tabs.
3811 =item B<v>I<STRING>B<.>
3813 Print I<STRING> for the value of a constant that can't be determined
3814 because it was optimized away (mnemonic: this happens when a constant
3815 is used in B<v>oid context). The end of the string is marked by a period.
3816 The string should be a valid perl expression, generally a constant.
3817 Note that unless it's a number, it probably needs to be quoted, and on
3818 a command line quotes need to be protected from the shell. Some
3819 conventional values include 0, 1, 42, '', 'foo', and
3820 'Useless use of constant omitted' (which may need to be
3821 B<-sv"'Useless use of constant omitted'.">
3822 or something similar depending on your shell). The default is '???'.
3823 If you're using B::Deparse on a module or other file that's require'd,
3824 you shouldn't use a value that evaluates to false, since the customary
3825 true constant at the end of a module will be in void context when the
3826 file is compiled as a main program.
3832 Expand conventional syntax constructions into equivalent ones that expose
3833 their internal operation. I<LEVEL> should be a digit, with higher values
3834 meaning more expansion. As with B<-q>, this actually involves turning off
3835 special cases in B::Deparse's normal operations.
3837 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3838 while loops with continue blocks; for instance
3840 for ($i = 0; $i < 10; ++$i) {
3853 Note that in a few cases this translation can't be perfectly carried back
3854 into the source code -- if the loop's initializer declares a my variable,
3855 for instance, it won't have the correct scope outside of the loop.
3857 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3858 expressions using C<&&>, C<?:> and C<do {}>; for instance
3860 print 'hi' if $nice;
3872 $nice and print 'hi';
3873 $nice and do { print 'hi' };
3874 $nice ? do { print 'hi' } : do { print 'bye' };
3876 Long sequences of elsifs will turn into nested ternary operators, which
3877 B::Deparse doesn't know how to indent nicely.
3881 =head1 USING B::Deparse AS A MODULE
3886 $deparse = B::Deparse->new("-p", "-sC");
3887 $body = $deparse->coderef2text(\&func);
3888 eval "sub func $body"; # the inverse operation
3892 B::Deparse can also be used on a sub-by-sub basis from other perl
3897 $deparse = B::Deparse->new(OPTIONS)
3899 Create an object to store the state of a deparsing operation and any
3900 options. The options are the same as those that can be given on the
3901 command line (see L</OPTIONS>); options that are separated by commas
3902 after B<-MO=Deparse> should be given as separate strings. Some
3903 options, like B<-u>, don't make sense for a single subroutine, so
3906 =head2 ambient_pragmas
3908 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3910 The compilation of a subroutine can be affected by a few compiler
3911 directives, B<pragmas>. These are:
3925 Assigning to the special variable $[
3945 Ordinarily, if you use B::Deparse on a subroutine which has
3946 been compiled in the presence of one or more of these pragmas,
3947 the output will include statements to turn on the appropriate
3948 directives. So if you then compile the code returned by coderef2text,
3949 it will behave the same way as the subroutine which you deparsed.
3951 However, you may know that you intend to use the results in a
3952 particular context, where some pragmas are already in scope. In
3953 this case, you use the B<ambient_pragmas> method to describe the
3954 assumptions you wish to make.
3956 Not all of the options currently have any useful effect. See
3957 L</BUGS> for more details.
3959 The parameters it accepts are:
3965 Takes a string, possibly containing several values separated
3966 by whitespace. The special values "all" and "none" mean what you'd
3969 $deparse->ambient_pragmas(strict => 'subs refs');
3973 Takes a number, the value of the array base $[.
3981 If the value is true, then the appropriate pragma is assumed to
3982 be in the ambient scope, otherwise not.
3986 Takes a string, possibly containing a whitespace-separated list of
3987 values. The values "all" and "none" are special. It's also permissible
3988 to pass an array reference here.
3990 $deparser->ambient_pragmas(re => 'eval');
3995 Takes a string, possibly containing a whitespace-separated list of
3996 values. The values "all" and "none" are special, again. It's also
3997 permissible to pass an array reference here.
3999 $deparser->ambient_pragmas(warnings => [qw[void io]]);
4001 If one of the values is the string "FATAL", then all the warnings
4002 in that list will be considered fatal, just as with the B<warnings>
4003 pragma itself. Should you need to specify that some warnings are
4004 fatal, and others are merely enabled, you can pass the B<warnings>
4007 $deparser->ambient_pragmas(
4009 warnings => [FATAL => qw/void io/],
4012 See L<perllexwarn> for more information about lexical warnings.
4018 These two parameters are used to specify the ambient pragmas in
4019 the format used by the special variables $^H and ${^WARNING_BITS}.
4021 They exist principally so that you can write code like:
4023 { my ($hint_bits, $warning_bits);
4024 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
4025 $deparser->ambient_pragmas (
4026 hint_bits => $hint_bits,
4027 warning_bits => $warning_bits,
4031 which specifies that the ambient pragmas are exactly those which
4032 are in scope at the point of calling.
4038 $body = $deparse->coderef2text(\&func)
4039 $body = $deparse->coderef2text(sub ($$) { ... })
4041 Return source code for the body of a subroutine (a block, optionally
4042 preceded by a prototype in parens), given a reference to the
4043 sub. Because a subroutine can have no names, or more than one name,
4044 this method doesn't return a complete subroutine definition -- if you
4045 want to eval the result, you should prepend "sub subname ", or "sub "
4046 for an anonymous function constructor. Unless the sub was defined in
4047 the main:: package, the code will include a package declaration.
4055 The only pragmas to be completely supported are: C<use warnings>,
4056 C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
4057 behaves like a pragma, is also supported.)
4059 Excepting those listed above, we're currently unable to guarantee that
4060 B::Deparse will produce a pragma at the correct point in the program.
4061 Since the effects of pragmas are often lexically scoped, this can mean
4062 that the pragma holds sway over a different portion of the program
4063 than in the input file.
4067 If a keyword is over-ridden, and your program explicitly calls
4068 the built-in version by using CORE::keyword, the output of B::Deparse
4069 will not reflect this.
4073 C<sort foo (1, 2, 3)> comes out as C<sort (foo 1, 2, 3)>, which
4074 causes perl to issue a warning.
4076 The obvious fix doesn't work, because these are different:
4078 print (FOO 1, 2, 3), 4, 5, 6;
4079 print FOO (1, 2, 3), 4, 5, 6;
4083 Constants (other than simple strings or numbers) don't work properly.
4084 Examples that fail include:
4086 use constant E2BIG => ($!=7);
4087 use constant x=>\$x; print x
4091 An input file that uses source filtering probably won't be deparsed into
4092 runnable code, because it will still include the B<use> declaration
4093 for the source filtering module, even though the code that is
4094 produced is already ordinary Perl which shouldn't be filtered again.
4098 There are probably many more bugs on non-ASCII platforms (EBCDIC).
4104 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
4105 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
4106 contributions from Gisle Aas, James Duncan, Albert Dvornik, Robin
4107 Houston, Hugo van der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.