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
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 # - finish tr/// changes
98 # - add option for even more parens (generalize \&foo change)
99 # - left/right context
100 # - treat top-level block specially for incremental output
101 # - copy comments (look at real text with $^P?)
102 # - avoid semis in one-statement blocks
103 # - associativity of &&=, ||=, ?:
104 # - ',' => '=>' (auto-unquote?)
105 # - break long lines ("\r" as discretionary break?)
106 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
107 # - more style options: brace style, hex vs. octal, quotes, ...
108 # - print big ints as hex/octal instead of decimal (heuristic?)
109 # - handle `my $x if 0'?
110 # - coordinate with Data::Dumper (both directions? see previous)
111 # - version using op_next instead of op_first/sibling?
112 # - avoid string copies (pass arrays, one big join?)
115 # Tests that will always fail:
116 # comp/redef.t -- all (redefinition happens at compile time)
118 # Object fields (were globals):
121 # (local($a), local($b)) and local($a, $b) have the same internal
122 # representation but the short form looks better. We notice we can
123 # use a large-scale local when checking the list, but need to prevent
124 # individual locals too. This hash holds the addresses of OPs that
125 # have already had their local-ness accounted for. The same thing
129 # CV for current sub (or main program) being deparsed
132 # Cached hash of lexical variables for curcv: keys are names,
133 # each value is an array of pairs, indicating the cop_seq of scopes
134 # in which a var of that name is valid.
137 # COP for statement being deparsed
140 # name of the current package for deparsed code
143 # array of [cop_seq, CV, is_format?] for subs and formats we still
147 # as above, but [name, prototype] for subs that never got a GV
149 # subs_done, forms_done:
150 # keys are addresses of GVs for subs and formats we've already
151 # deparsed (or at least put into subs_todo)
154 # keys are names of subs for which we've printed declarations.
155 # That means we can omit parentheses from the arguments.
160 # cuddle: ` ' or `\n', depending on -sC
165 # A little explanation of how precedence contexts and associativity
168 # deparse() calls each per-op subroutine with an argument $cx (short
169 # for context, but not the same as the cx* in the perl core), which is
170 # a number describing the op's parents in terms of precedence, whether
171 # they're inside an expression or at statement level, etc. (see
172 # chart below). When ops with children call deparse on them, they pass
173 # along their precedence. Fractional values are used to implement
174 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
175 # parentheses hacks. The major disadvantage of this scheme is that
176 # it doesn't know about right sides and left sides, so say if you
177 # assign a listop to a variable, it can't tell it's allowed to leave
178 # the parens off the listop.
181 # 26 [TODO] inside interpolation context ("")
182 # 25 left terms and list operators (leftward)
186 # 21 right ! ~ \ and unary + and -
191 # 16 nonassoc named unary operators
192 # 15 nonassoc < > <= >= lt gt le ge
193 # 14 nonassoc == != <=> eq ne cmp
200 # 7 right = += -= *= etc.
202 # 5 nonassoc list operators (rightward)
206 # 1 statement modifiers
209 # Also, lineseq may pass a fourth parameter to the pp_ routines:
210 # if present, the fourth parameter is passed on by deparse.
212 # If present and true, it means that the op exists directly as
213 # part of a lineseq. Currently it's only used by scopeop to
214 # decide whether its results need to be enclosed in a do {} block.
216 # Nonprinting characters with special meaning:
217 # \cS - steal parens (see maybe_parens_unop)
218 # \n - newline and indent
219 # \t - increase indent
220 # \b - decrease indent (`outdent')
221 # \f - flush left (no indent)
222 # \cK - kill following semicolon, if any
226 return class($op) eq "NULL";
231 my($cv, $is_form) = @_;
232 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
234 if (!null($cv->START) and is_state($cv->START)) {
235 $seq = $cv->START->cop_seq;
239 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
244 my $ent = shift @{$self->{'subs_todo'}};
247 my $name = $self->gv_name($gv);
249 return "format $name =\n"
250 . $self->deparse_format($ent->[1]). "\n";
252 $self->{'subs_declared'}{$name} = 1;
253 if ($name eq "BEGIN") {
254 my $use_dec = $self->begin_is_use($cv);
255 if (defined ($use_dec)) {
256 return () if 0 == length($use_dec);
261 if ($self->{'linenums'}) {
262 my $line = $gv->LINE;
263 my $file = $gv->FILE;
264 $l = "\n\f#line $line \"$file\"\n";
266 return "${l}sub $name " . $self->deparse_sub($cv);
270 # Return a "use" declaration for this BEGIN block, if appropriate
272 my ($self, $cv) = @_;
273 my $root = $cv->ROOT;
275 #B::walkoptree($cv->ROOT, "debug");
276 my $lineseq = $root->first;
277 return if $lineseq->name ne "lineseq";
279 my $req_op = $lineseq->first->sibling;
280 return if $req_op->name ne "require";
283 if ($req_op->first->private & OPpCONST_BARE) {
284 # Actually it should always be a bareword
285 $module = $self->const_sv($req_op->first)->PV;
286 $module =~ s[/][::]g;
290 $module = const($self->const_sv($req_op->first));
294 my $version_op = $req_op->sibling;
295 return if class($version_op) eq "NULL";
296 if ($version_op->name eq "lineseq") {
297 # We have a version parameter; skip nextstate & pushmark
298 my $constop = $version_op->first->next->next;
300 return unless $self->const_sv($constop)->PV eq $module;
301 $constop = $constop->sibling;
302 $version = $self->const_sv($constop)->int_value;
303 $constop = $constop->sibling;
304 return if $constop->name ne "method_named";
305 return if $self->const_sv($constop)->PV ne "VERSION";
308 $lineseq = $version_op->sibling;
309 return if $lineseq->name ne "lineseq";
310 my $entersub = $lineseq->first->sibling;
311 if ($entersub->name eq "stub") {
312 return "use $module $version ();\n" if defined $version;
313 return "use $module ();\n";
315 return if $entersub->name ne "entersub";
317 # See if there are import arguments
320 my $svop = $entersub->first->sibling; # Skip over pushmark
321 return unless $self->const_sv($svop)->PV eq $module;
323 # Pull out the arguments
324 for ($svop=$svop->sibling; $svop->name ne "method_named";
325 $svop = $svop->sibling) {
326 $args .= ", " if length($args);
327 $args .= $self->deparse($svop, 6);
331 my $method_named = $svop;
332 return if $method_named->name ne "method_named";
333 my $method_name = $self->const_sv($method_named)->PV;
335 if ($method_name eq "unimport") {
339 # Certain pragmas are dealt with using hint bits,
340 # so we ignore them here
341 if ($module eq 'strict' || $module eq 'integer'
342 || $module eq 'bytes' || $module eq 'warnings') {
346 if (defined $version && length $args) {
347 return "$use $module $version ($args);\n";
348 } elsif (defined $version) {
349 return "$use $module $version;\n";
350 } elsif (length $args) {
351 return "$use $module ($args);\n";
353 return "$use $module;\n";
358 my ($self, $pack) = @_;
360 if (!defined $pack) {
365 $pack =~ s/(::)?$/::/;
369 my %stash = svref_2object($stash)->ARRAY;
370 while (my ($key, $val) = each %stash) {
371 next if $key eq 'main::'; # avoid infinite recursion
372 my $class = class($val);
373 if ($class eq "PV") {
374 # Just a prototype. As an ugly but fairly effective way
375 # to find out if it belongs here is to see if the AUTOLOAD
376 # (if any) for the stash was defined in one of our files.
377 my $A = $stash{"AUTOLOAD"};
378 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
379 && class($A->CV) eq "CV") {
381 next unless $AF eq $0 || exists $self->{'files'}{$AF};
383 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
384 } elsif ($class eq "IV") {
385 # Just a name. As above.
386 my $A = $stash{"AUTOLOAD"};
387 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
388 && class($A->CV) eq "CV") {
390 next unless $AF eq $0 || exists $self->{'files'}{$AF};
392 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
393 } elsif ($class eq "GV") {
394 if (class(my $cv = $val->CV) ne "SPECIAL") {
395 next if $self->{'subs_done'}{$$val}++;
396 next if $$val != ${$cv->GV}; # Ignore imposters
399 if (class(my $cv = $val->FORM) ne "SPECIAL") {
400 next if $self->{'forms_done'}{$$val}++;
401 next if $$val != ${$cv->GV}; # Ignore imposters
404 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
405 $self->stash_subs($pack . $key);
415 foreach $ar (@{$self->{'protos_todo'}}) {
416 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
417 push @ret, "sub " . $ar->[0] . "$proto;\n";
419 delete $self->{'protos_todo'};
427 while (length($opt = substr($opts, 0, 1))) {
429 $self->{'cuddle'} = " ";
430 $opts = substr($opts, 1);
431 } elsif ($opt eq "i") {
432 $opts =~ s/^i(\d+)//;
433 $self->{'indent_size'} = $1;
434 } elsif ($opt eq "T") {
435 $self->{'use_tabs'} = 1;
436 $opts = substr($opts, 1);
437 } elsif ($opt eq "v") {
438 $opts =~ s/^v([^.]*)(.|$)//;
439 $self->{'ex_const'} = $1;
446 my $self = bless {}, $class;
447 $self->{'subs_todo'} = [];
448 $self->{'files'} = {};
449 $self->{'curstash'} = "main";
450 $self->{'curcop'} = undef;
451 $self->{'cuddle'} = "\n";
452 $self->{'indent_size'} = 4;
453 $self->{'use_tabs'} = 0;
454 $self->{'expand'} = 0;
455 $self->{'unquote'} = 0;
456 $self->{'linenums'} = 0;
457 $self->{'parens'} = 0;
458 $self->{'ex_const'} = "'???'";
460 $self->{'ambient_arybase'} = 0;
461 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
462 $self->{'ambient_hints'} = 0;
465 while (my $arg = shift @_) {
466 if ($arg =~ /^-f(.*)/) {
467 $self->{'files'}{$1} = 1;
468 } elsif ($arg eq "-p") {
469 $self->{'parens'} = 1;
470 } elsif ($arg eq "-l") {
471 $self->{'linenums'} = 1;
472 } elsif ($arg eq "-q") {
473 $self->{'unquote'} = 1;
474 } elsif (substr($arg, 0, 2) eq "-s") {
475 $self->style_opts(substr $arg, 2);
476 } elsif ($arg =~ /^-x(\d)$/) {
477 $self->{'expand'} = $1;
484 # Mask out the bits that C<use vars> uses
485 $warnings::Bits{all} | $warnings::DeadBits{all};
488 # Initialise the contextual information, either from
489 # defaults provided with the ambient_pragmas method,
490 # or from perl's own defaults otherwise.
494 $self->{'arybase'} = $self->{'ambient_arybase'};
495 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
496 ? $self->{'ambient_warnings'} & WARN_MASK
498 $self->{'hints'} = $self->{'ambient_hints'} & 0xFF;
500 # also a convenient place to clear out subs_declared
501 delete $self->{'subs_declared'};
507 my $self = B::Deparse->new(@args);
508 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
509 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
510 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
511 for my $block (@BEGINs, @INITs, @ENDs) {
512 $self->todo($block, 0);
515 $self->{'curcv'} = main_cv;
516 $self->{'curcvlex'} = undef;
517 print $self->print_protos;
518 @{$self->{'subs_todo'}} =
519 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
520 print $self->indent($self->deparse(main_root, 0)), "\n"
521 unless null main_root;
523 while (scalar(@{$self->{'subs_todo'}})) {
524 push @text, $self->next_todo;
526 print $self->indent(join("", @text)), "\n" if @text;
528 # Print __DATA__ section, if necessary
530 if (defined *{$self->{'curstash'}."::DATA"}{IO}) {
532 print readline(*{$self->{'curstash'}."::DATA"});
540 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
543 return $self->indent($self->deparse_sub(svref_2object($sub)));
546 sub ambient_pragmas {
548 my ($arybase, $hint_bits, $warning_bits) = (0, 0);
554 if ($name eq 'strict') {
557 if ($val eq 'none') {
558 $hint_bits &= ~strict::bits(qw/refs subs vars/);
564 @names = qw/refs subs vars/;
570 @names = split' ', $val;
572 $hint_bits |= strict::bits(@names);
575 elsif ($name eq '$[') {
579 elsif ($name eq 'integer'
581 || $name eq 'utf8') {
584 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
587 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
591 elsif ($name eq 're') {
593 if ($val eq 'none') {
594 $hint_bits &= ~re::bits(qw/taint eval asciirange/);
600 @names = qw/taint eval asciirange/;
606 @names = split' ',$val;
608 $hint_bits |= re::bits(@names);
611 elsif ($name eq 'warnings') {
612 if ($val eq 'none') {
613 $warning_bits = "\0"x12;
622 @names = split/\s+/, $val;
625 $warning_bits = "\0"x12 if !defined ($warning_bits);
626 $warning_bits |= warnings::bits(@names);
629 elsif ($name eq 'warning_bits') {
630 $warning_bits = $val;
633 elsif ($name eq 'hint_bits') {
638 croak "Unknown pragma type: $name";
642 croak "The ambient_pragmas method expects an even number of args";
645 $self->{'ambient_arybase'} = $arybase;
646 $self->{'ambient_warnings'} = $warning_bits;
647 $self->{'ambient_hints'} = $hint_bits;
652 my($op, $cx, $flags) = @_;
654 Carp::confess("Null op in deparse") if !defined($op)
655 || class($op) eq "NULL";
656 my $meth = "pp_" . $op->name;
658 return $self->$meth($op, $cx, $flags);
660 return $self->$meth($op, $cx);
666 my @lines = split(/\n/, $txt);
671 my $cmd = substr($line, 0, 1);
672 if ($cmd eq "\t" or $cmd eq "\b") {
673 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
674 if ($self->{'use_tabs'}) {
675 $leader = "\t" x ($level / 8) . " " x ($level % 8);
677 $leader = " " x $level;
679 $line = substr($line, 1);
681 if (substr($line, 0, 1) eq "\f") {
682 $line = substr($line, 1); # no indent
684 $line = $leader . $line;
688 return join("\n", @lines);
695 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
696 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
697 local $self->{'curcop'} = $self->{'curcop'};
698 if ($cv->FLAGS & SVf_POK) {
699 $proto = "(". $cv->PV . ") ";
701 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
703 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
704 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
705 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
708 local($self->{'curcv'}) = $cv;
709 local($self->{'curcvlex'});
710 local(@$self{qw'curstash warnings hints'})
711 = @$self{qw'curstash warnings hints'};
713 if (not null $cv->ROOT) {
714 my $lineseq = $cv->ROOT->first;
715 if ($lineseq->name eq "lineseq") {
717 for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
720 $body = $self->lineseq(undef, @ops).";";
721 my $scope_en = $self->find_scope_en($lineseq);
722 if (defined $scope_en) {
723 my $subs = join"", $self->seq_subs($scope_en);
724 $body .= ";\n$subs" if length($subs);
728 $body = $self->deparse($cv->ROOT->first, 0);
732 my $sv = $cv->const_sv;
734 # uh-oh. inlinable sub... format it differently
735 return $proto . "{ " . const($sv) . " }\n";
736 } else { # XSUB? (or just a declaration)
740 return $proto ."{\n\t$body\n\b}" ."\n";
747 local($self->{'curcv'}) = $form;
748 local($self->{'curcvlex'});
749 local(@$self{qw'curstash warnings hints'})
750 = @$self{'curstash warnings hints'};
751 my $op = $form->ROOT;
753 $op = $op->first->first; # skip leavewrite, lineseq
754 while (not null $op) {
755 $op = $op->sibling; # skip nextstate
757 $kid = $op->first->sibling; # skip pushmark
758 push @text, "\f".$self->const_sv($kid)->PV;
759 $kid = $kid->sibling;
760 for (; not null $kid; $kid = $kid->sibling) {
761 push @exprs, $self->deparse($kid, 0);
763 push @text, "\f".join(", ", @exprs)."\n" if @exprs;
766 return join("", @text) . "\f.";
771 return $op->name eq "leave" || $op->name eq "scope"
772 || $op->name eq "lineseq"
773 || ($op->name eq "null" && class($op) eq "UNOP"
774 && (is_scope($op->first) || $op->first->name eq "enter"));
778 my $name = $_[0]->name;
779 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
782 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
784 return (!null($op) and null($op->sibling)
785 and $op->name eq "null" and class($op) eq "UNOP"
786 and (($op->first->name =~ /^(and|or)$/
787 and $op->first->first->sibling->name eq "lineseq")
788 or ($op->first->name eq "lineseq"
789 and not null $op->first->first->sibling
790 and $op->first->first->sibling->name eq "unstack")
796 return ($op->name eq "rv2sv" or
797 $op->name eq "padsv" or
798 $op->name eq "gv" or # only in array/hash constructs
799 $op->flags & OPf_KIDS && !null($op->first)
800 && $op->first->name eq "gvsv");
805 my($text, $cx, $prec) = @_;
806 if ($prec < $cx # unary ops nest just fine
807 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
808 or $self->{'parens'})
811 # In a unop, let parent reuse our parens; see maybe_parens_unop
812 $text = "\cS" . $text if $cx == 16;
819 # same as above, but get around the `if it looks like a function' rule
820 sub maybe_parens_unop {
822 my($name, $kid, $cx) = @_;
823 if ($cx > 16 or $self->{'parens'}) {
824 $kid = $self->deparse($kid, 1);
825 if ($name eq "umask" && $kid =~ /^\d+$/) {
826 $kid = sprintf("%#o", $kid);
828 return "$name($kid)";
830 $kid = $self->deparse($kid, 16);
831 if ($name eq "umask" && $kid =~ /^\d+$/) {
832 $kid = sprintf("%#o", $kid);
834 if (substr($kid, 0, 1) eq "\cS") {
836 return $name . substr($kid, 1);
837 } elsif (substr($kid, 0, 1) eq "(") {
838 # avoid looks-like-a-function trap with extra parens
839 # (`+' can lead to ambiguities)
840 return "$name(" . $kid . ")";
847 sub maybe_parens_func {
849 my($func, $text, $cx, $prec) = @_;
850 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
851 return "$func($text)";
853 return "$func $text";
859 my($op, $cx, $text) = @_;
860 my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
861 if ($op->private & (OPpLVAL_INTRO|$our_intro)
862 and not $self->{'avoid_local'}{$$op}) {
863 my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
864 if (want_scalar($op)) {
865 return "$our_local $text";
867 return $self->maybe_parens_func("$our_local", $text, $cx, 16);
876 my($op, $cx, $func, @args) = @_;
877 if ($op->private & OPpTARGET_MY) {
878 my $var = $self->padname($op->targ);
879 my $val = $func->($self, $op, 7, @args);
880 return $self->maybe_parens("$var = $val", $cx, 7);
882 return $func->($self, $op, $cx, @args);
889 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
894 my($op, $cx, $text) = @_;
895 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
896 if (want_scalar($op)) {
899 return $self->maybe_parens_func("my", $text, $cx, 16);
906 # The following OPs don't have functions:
908 # pp_padany -- does not exist after parsing
909 # pp_rcatline -- does not exist
911 sub pp_enter { # see also leave
912 cluck "unexpected OP_ENTER";
916 sub pp_pushmark { # see also list
917 cluck "unexpected OP_PUSHMARK";
921 sub pp_leavesub { # see also deparse_sub
922 cluck "unexpected OP_LEAVESUB";
926 sub pp_leavewrite { # see also deparse_format
927 cluck "unexpected OP_LEAVEWRITE";
931 sub pp_method { # see also entersub
932 cluck "unexpected OP_METHOD";
936 sub pp_regcmaybe { # see also regcomp
937 cluck "unexpected OP_REGCMAYBE";
941 sub pp_regcreset { # see also regcomp
942 cluck "unexpected OP_REGCRESET";
946 sub pp_substcont { # see also subst
947 cluck "unexpected OP_SUBSTCONT";
951 sub pp_grepstart { # see also grepwhile
952 cluck "unexpected OP_GREPSTART";
956 sub pp_mapstart { # see also mapwhile
957 cluck "unexpected OP_MAPSTART";
961 sub pp_flip { # see also flop
962 cluck "unexpected OP_FLIP";
966 sub pp_iter { # see also leaveloop
967 cluck "unexpected OP_ITER";
971 sub pp_enteriter { # see also leaveloop
972 cluck "unexpected OP_ENTERITER";
976 sub pp_enterloop { # see also leaveloop
977 cluck "unexpected OP_ENTERLOOP";
981 sub pp_leaveeval { # see also entereval
982 cluck "unexpected OP_LEAVEEVAL";
986 sub pp_entertry { # see also leavetry
987 cluck "unexpected OP_ENTERTRY";
991 # $root should be the op which represents the root of whatever
992 # we're sequencing here. If it's undefined, then we don't append
993 # any subroutine declarations to the deparsed ops, otherwise we
994 # append appropriate declarations.
996 my($self, $root, @ops) = @_;
999 my $out_cop = $self->{'curcop'};
1000 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1002 if (defined $root) {
1003 $limit_seq = $out_seq;
1004 my $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
1005 $limit_seq = $nseq if !defined($limit_seq)
1006 or defined($nseq) && $nseq < $limit_seq;
1008 $limit_seq = $self->{'limit_seq'}
1009 if defined($self->{'limit_seq'})
1010 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1011 local $self->{'limit_seq'} = $limit_seq;
1012 for (my $i = 0; $i < @ops; $i++) {
1014 if (is_state $ops[$i]) {
1015 $expr = $self->deparse($ops[$i], 0);
1022 if (!is_state $ops[$i] and (my $ls = $ops[$i+1]) and
1023 !null($ops[$i+1]) and $ops[$i+1]->name eq "lineseq")
1025 if ($ls->first && !null($ls->first) && is_state($ls->first)
1026 && (my $sib = $ls->first->sibling)) {
1027 if (!null($sib) && $sib->name eq "leaveloop") {
1028 push @exprs, $expr . $self->for_loop($ops[$i], 0);
1034 $expr .= $self->deparse($ops[$i], 0, (@ops != 1));
1035 $expr =~ s/;\n?\z//;
1038 my $body = join(";\n", grep {length} @exprs);
1040 if (defined $root && defined $limit_seq) {
1041 $subs = join "\n", $self->seq_subs($limit_seq);
1043 return join(";\n", grep {length} $body, $subs);
1047 my($real_block, $self, $op, $cx, $flags) = @_;
1051 local(@$self{qw'curstash warnings hints'})
1052 = @$self{qw'curstash warnings hints'} if $real_block;
1054 $kid = $op->first->sibling; # skip enter
1055 if (is_miniwhile($kid)) {
1056 my $top = $kid->first;
1057 my $name = $top->name;
1058 if ($name eq "and") {
1060 } elsif ($name eq "or") {
1062 } else { # no conditional -> while 1 or until 0
1063 return $self->deparse($top->first, 1) . " while 1";
1065 my $cond = $top->first;
1066 my $body = $cond->sibling->first; # skip lineseq
1067 $cond = $self->deparse($cond, 1);
1068 $body = $self->deparse($body, 1);
1069 return "$body $name $cond";
1074 for (; !null($kid); $kid = $kid->sibling) {
1077 if ($flags || $cx > 0) { # inside an expression, (a do {} while for lineseq)
1078 return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
1080 my $lineseq = $self->lineseq($op, @kids);
1081 return (length ($lineseq) ? "$lineseq;" : "");
1085 sub pp_scope { scopeop(0, @_); }
1086 sub pp_lineseq { scopeop(0, @_); }
1087 sub pp_leave { scopeop(1, @_); }
1089 # The BEGIN {} is used here because otherwise this code isn't executed
1090 # when you run B::Deparse on itself.
1092 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1093 "ENV", "ARGV", "ARGVOUT", "_"); }
1098 Carp::confess() if $gv->isa("B::CV");
1099 my $stash = $gv->STASH->NAME;
1100 my $name = $gv->SAFENAME;
1101 if ($stash eq $self->{'curstash'} or $globalnames{$name}
1102 or $name =~ /^[^A-Za-z_]/)
1106 $stash = $stash . "::";
1108 if ($name =~ /^\^../) {
1109 $name = "{$name}"; # ${^WARNING_BITS} etc
1111 return $stash . $name;
1114 # Return the name to use for a stash variable.
1115 # If a lexical with the same name is in scope, it may need to be
1117 sub stash_variable {
1118 my ($self, $prefix, $name) = @_;
1120 return "$prefix$name" if $name =~ /::/;
1122 unless ($prefix eq '$' || $prefix eq '@' ||
1123 $prefix eq '%' || $prefix eq '$#') {
1124 return "$prefix$name";
1127 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1128 return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
1129 return "$prefix$name";
1133 my ($self, $name) = @_;
1134 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1136 return 0 if !defined($self->{'curcop'});
1137 my $seq = $self->{'curcop'}->cop_seq;
1138 return 0 if !exists $self->{'curcvlex'}{$name};
1139 for my $a (@{$self->{'curcvlex'}{$name}}) {
1140 my ($st, $en) = @$a;
1141 return 1 if $seq > $st && $seq <= $en;
1146 sub populate_curcvlex {
1148 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1149 my @padlist = $cv->PADLIST->ARRAY;
1150 my @ns = $padlist[0]->ARRAY;
1152 for (my $i=0; $i<@ns; ++$i) {
1153 next if class($ns[$i]) eq "SPECIAL";
1154 next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars
1155 if (class($ns[$i]) eq "PV") {
1156 # Probably that pesky lexical @_
1159 my $name = $ns[$i]->PVX;
1160 my $seq_st = $ns[$i]->NVX;
1161 my $seq_en = int($ns[$i]->IVX);
1163 push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
1168 sub find_scope_st { ((find_scope(@_))[0]); }
1169 sub find_scope_en { ((find_scope(@_))[1]); }
1171 # Recurses down the tree, looking for pad variable introductions and COPs
1173 my ($self, $op, $scope_st, $scope_en) = @_;
1174 Carp::cluck() if !defined $op;
1175 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1177 for (my $o=$op->first; $$o; $o=$o->sibling) {
1178 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1179 my $s = int($self->padname_sv($o->targ)->NVX);
1180 my $e = $self->padname_sv($o->targ)->IVX;
1181 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1182 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1184 elsif (is_state($o)) {
1185 my $c = $o->cop_seq;
1186 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1187 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1189 elsif ($o->flags & OPf_KIDS) {
1190 ($scope_st, $scope_en) =
1191 $self->find_scope($o, $scope_st, $scope_en)
1195 return ($scope_st, $scope_en);
1198 # Returns a list of subs which should be inserted before the COP
1200 my ($self, $op, $out_seq) = @_;
1201 my $seq = $op->cop_seq;
1202 # If we have nephews, then our sequence number indicates
1203 # the cop_seq of the end of some sort of scope.
1204 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1205 and my $nseq = $self->find_scope_st($op->sibling) ) {
1208 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1209 return $self->seq_subs($seq);
1213 my ($self, $seq) = @_;
1215 #push @text, "# ($seq)\n";
1217 return "" if !defined $seq;
1218 while (scalar(@{$self->{'subs_todo'}})
1219 and $seq > $self->{'subs_todo'}[0][0]) {
1220 push @text, $self->next_todo;
1225 # Notice how subs and formats are inserted between statements here;
1226 # also $[ assignments and pragmas.
1230 $self->{'curcop'} = $op;
1232 push @text, $self->cop_subs($op);
1233 push @text, $op->label . ": " if $op->label;
1234 my $stash = $op->stashpv;
1235 if ($stash ne $self->{'curstash'}) {
1236 push @text, "package $stash;\n";
1237 $self->{'curstash'} = $stash;
1239 if ($self->{'linenums'}) {
1240 push @text, "\f#line " . $op->line .
1241 ' "' . $op->file, qq'"\n';
1244 if ($self->{'arybase'} != $op->arybase) {
1245 push @text, '$[ = '. $op->arybase .";\n";
1246 $self->{'arybase'} = $op->arybase;
1249 my $warnings = $op->warnings;
1251 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1252 $warning_bits = $warnings::Bits{"all"};
1254 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1255 $warning_bits = "\0"x12;
1257 elsif ($warnings->isa("B::SPECIAL")) {
1258 $warning_bits = undef;
1261 $warning_bits = $warnings->PV & WARN_MASK;
1264 if (defined ($warning_bits) and
1265 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1266 push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1267 $self->{'warnings'} = $warning_bits;
1270 if ($self->{'hints'} != $op->private) {
1271 push @text, declare_hints($self->{'hints'}, $op->private);
1272 $self->{'hints'} = $op->private;
1275 return join("", @text);
1278 sub declare_warnings {
1279 my ($from, $to) = @_;
1280 if (($to & WARN_MASK) eq warnings::bits("all")) {
1281 return "use warnings;\n";
1283 elsif (($to & WARN_MASK) eq "\0"x length($to)) {
1284 return "no warnings;\n";
1286 return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n";
1290 my ($from, $to) = @_;
1291 my $use = $to & ~$from;
1292 my $no = $from & ~$to;
1294 for my $pragma (hint_pragmas($use)) {
1295 $decls .= "use $pragma;\n";
1297 for my $pragma (hint_pragmas($no)) {
1298 $decls .= "no $pragma;\n";
1306 push @pragmas, "integer" if $bits & 0x1;
1307 push @pragmas, "strict 'refs'" if $bits & 0x2;
1308 push @pragmas, "bytes" if $bits & 0x8;
1312 sub pp_dbstate { pp_nextstate(@_) }
1313 sub pp_setstate { pp_nextstate(@_) }
1315 sub pp_unstack { return "" } # see also leaveloop
1319 my($op, $cx, $name) = @_;
1325 my($op, $cx, $name) = @_;
1333 sub pp_wantarray { baseop(@_, "wantarray") }
1334 sub pp_fork { baseop(@_, "fork") }
1335 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1336 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1337 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1338 sub pp_tms { baseop(@_, "times") }
1339 sub pp_ghostent { baseop(@_, "gethostent") }
1340 sub pp_gnetent { baseop(@_, "getnetent") }
1341 sub pp_gprotoent { baseop(@_, "getprotoent") }
1342 sub pp_gservent { baseop(@_, "getservent") }
1343 sub pp_ehostent { baseop(@_, "endhostent") }
1344 sub pp_enetent { baseop(@_, "endnetent") }
1345 sub pp_eprotoent { baseop(@_, "endprotoent") }
1346 sub pp_eservent { baseop(@_, "endservent") }
1347 sub pp_gpwent { baseop(@_, "getpwent") }
1348 sub pp_spwent { baseop(@_, "setpwent") }
1349 sub pp_epwent { baseop(@_, "endpwent") }
1350 sub pp_ggrent { baseop(@_, "getgrent") }
1351 sub pp_sgrent { baseop(@_, "setgrent") }
1352 sub pp_egrent { baseop(@_, "endgrent") }
1353 sub pp_getlogin { baseop(@_, "getlogin") }
1355 sub POSTFIX () { 1 }
1357 # I couldn't think of a good short name, but this is the category of
1358 # symbolic unary operators with interesting precedence
1362 my($op, $cx, $name, $prec, $flags) = (@_, 0);
1363 my $kid = $op->first;
1364 $kid = $self->deparse($kid, $prec);
1365 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1369 sub pp_preinc { pfixop(@_, "++", 23) }
1370 sub pp_predec { pfixop(@_, "--", 23) }
1371 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1372 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1373 sub pp_i_preinc { pfixop(@_, "++", 23) }
1374 sub pp_i_predec { pfixop(@_, "--", 23) }
1375 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1376 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1377 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1379 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1383 if ($op->first->name =~ /^(i_)?negate$/) {
1385 $self->pfixop($op, $cx, "-", 21.5);
1387 $self->pfixop($op, $cx, "-", 21);
1390 sub pp_i_negate { pp_negate(@_) }
1396 $self->pfixop($op, $cx, "not ", 4);
1398 $self->pfixop($op, $cx, "!", 21);
1404 my($op, $cx, $name) = @_;
1406 if ($op->flags & OPf_KIDS) {
1408 if (defined prototype("CORE::$name")
1409 && prototype("CORE::$name") =~ /^;?\*/
1410 && $kid->name eq "rv2gv") {
1414 return $self->maybe_parens_unop($name, $kid, $cx);
1416 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1420 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1421 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1422 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1423 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1424 sub pp_defined { unop(@_, "defined") }
1425 sub pp_undef { unop(@_, "undef") }
1426 sub pp_study { unop(@_, "study") }
1427 sub pp_ref { unop(@_, "ref") }
1428 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1430 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1431 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1432 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1433 sub pp_srand { unop(@_, "srand") }
1434 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1435 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1436 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1437 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1438 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1439 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1440 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1442 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1443 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1444 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1446 sub pp_each { unop(@_, "each") }
1447 sub pp_values { unop(@_, "values") }
1448 sub pp_keys { unop(@_, "keys") }
1449 sub pp_pop { unop(@_, "pop") }
1450 sub pp_shift { unop(@_, "shift") }
1452 sub pp_caller { unop(@_, "caller") }
1453 sub pp_reset { unop(@_, "reset") }
1454 sub pp_exit { unop(@_, "exit") }
1455 sub pp_prototype { unop(@_, "prototype") }
1457 sub pp_close { unop(@_, "close") }
1458 sub pp_fileno { unop(@_, "fileno") }
1459 sub pp_umask { unop(@_, "umask") }
1460 sub pp_untie { unop(@_, "untie") }
1461 sub pp_tied { unop(@_, "tied") }
1462 sub pp_dbmclose { unop(@_, "dbmclose") }
1463 sub pp_getc { unop(@_, "getc") }
1464 sub pp_eof { unop(@_, "eof") }
1465 sub pp_tell { unop(@_, "tell") }
1466 sub pp_getsockname { unop(@_, "getsockname") }
1467 sub pp_getpeername { unop(@_, "getpeername") }
1469 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1470 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1471 sub pp_readlink { unop(@_, "readlink") }
1472 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1473 sub pp_readdir { unop(@_, "readdir") }
1474 sub pp_telldir { unop(@_, "telldir") }
1475 sub pp_rewinddir { unop(@_, "rewinddir") }
1476 sub pp_closedir { unop(@_, "closedir") }
1477 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1478 sub pp_localtime { unop(@_, "localtime") }
1479 sub pp_gmtime { unop(@_, "gmtime") }
1480 sub pp_alarm { unop(@_, "alarm") }
1481 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1483 sub pp_dofile { unop(@_, "do") }
1484 sub pp_entereval { unop(@_, "eval") }
1486 sub pp_ghbyname { unop(@_, "gethostbyname") }
1487 sub pp_gnbyname { unop(@_, "getnetbyname") }
1488 sub pp_gpbyname { unop(@_, "getprotobyname") }
1489 sub pp_shostent { unop(@_, "sethostent") }
1490 sub pp_snetent { unop(@_, "setnetent") }
1491 sub pp_sprotoent { unop(@_, "setprotoent") }
1492 sub pp_sservent { unop(@_, "setservent") }
1493 sub pp_gpwnam { unop(@_, "getpwnam") }
1494 sub pp_gpwuid { unop(@_, "getpwuid") }
1495 sub pp_ggrnam { unop(@_, "getgrnam") }
1496 sub pp_ggrgid { unop(@_, "getgrgid") }
1498 sub pp_lock { unop(@_, "lock") }
1504 if ($op->private & OPpEXISTS_SUB) {
1505 # Checking for the existence of a subroutine
1506 return $self->maybe_parens_func("exists",
1507 $self->pp_rv2cv($op->first, 16), $cx, 16);
1509 if ($op->flags & OPf_SPECIAL) {
1510 # Array element, not hash element
1511 return $self->maybe_parens_func("exists",
1512 $self->pp_aelem($op->first, 16), $cx, 16);
1514 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1522 if ($op->private & OPpSLICE) {
1523 if ($op->flags & OPf_SPECIAL) {
1524 # Deleting from an array, not a hash
1525 return $self->maybe_parens_func("delete",
1526 $self->pp_aslice($op->first, 16),
1529 return $self->maybe_parens_func("delete",
1530 $self->pp_hslice($op->first, 16),
1533 if ($op->flags & OPf_SPECIAL) {
1534 # Deleting from an array, not a hash
1535 return $self->maybe_parens_func("delete",
1536 $self->pp_aelem($op->first, 16),
1539 return $self->maybe_parens_func("delete",
1540 $self->pp_helem($op->first, 16),
1548 if (class($op) eq "UNOP" and $op->first->name eq "const"
1549 and $op->first->private & OPpCONST_BARE)
1551 my $name = $self->const_sv($op->first)->PV;
1554 return "require $name";
1556 $self->unop($op, $cx, "require");
1563 my $kid = $op->first;
1564 if (not null $kid->sibling) {
1565 # XXX Was a here-doc
1566 return $self->dquote($op);
1568 $self->unop(@_, "scalar");
1575 #cluck "curcv was undef" unless $self->{curcv};
1576 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1582 my $kid = $op->first;
1583 if ($kid->name eq "null") {
1585 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1586 my($pre, $post) = @{{"anonlist" => ["[","]"],
1587 "anonhash" => ["{","}"]}->{$kid->name}};
1589 $kid = $kid->first->sibling; # skip pushmark
1590 for (; !null($kid); $kid = $kid->sibling) {
1591 $expr = $self->deparse($kid, 6);
1594 return $pre . join(", ", @exprs) . $post;
1595 } elsif (!null($kid->sibling) and
1596 $kid->sibling->name eq "anoncode") {
1598 $self->deparse_sub($self->padval($kid->sibling->targ));
1599 } elsif ($kid->name eq "pushmark") {
1600 my $sib_name = $kid->sibling->name;
1601 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1602 and not $kid->sibling->flags & OPf_REF)
1604 # The @a in \(@a) isn't in ref context, but only when the
1606 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1607 } elsif ($sib_name eq 'entersub') {
1608 my $text = $self->deparse($kid->sibling, 1);
1609 # Always show parens for \(&func()), but only with -p otherwise
1610 $text = "($text)" if $self->{'parens'}
1611 or $kid->sibling->private & OPpENTERSUB_AMPER;
1616 $self->pfixop($op, $cx, "\\", 20);
1619 sub pp_srefgen { pp_refgen(@_) }
1624 my $kid = $op->first;
1625 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1626 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
1627 return $self->unop($op, $cx, "readline");
1630 # Unary operators that can occur as pseudo-listops inside double quotes
1633 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1635 if ($op->flags & OPf_KIDS) {
1637 # If there's more than one kid, the first is an ex-pushmark.
1638 $kid = $kid->sibling if not null $kid->sibling;
1639 return $self->maybe_parens_unop($name, $kid, $cx);
1641 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1645 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1646 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1647 sub pp_uc { dq_unop(@_, "uc") }
1648 sub pp_lc { dq_unop(@_, "lc") }
1649 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1653 my ($op, $cx, $name) = @_;
1654 if (class($op) eq "PVOP") {
1655 return "$name " . $op->pv;
1656 } elsif (class($op) eq "OP") {
1658 } elsif (class($op) eq "UNOP") {
1659 # Note -- loop exits are actually exempt from the
1660 # looks-like-a-func rule, but a few extra parens won't hurt
1661 return $self->maybe_parens_unop($name, $op->first, $cx);
1665 sub pp_last { loopex(@_, "last") }
1666 sub pp_next { loopex(@_, "next") }
1667 sub pp_redo { loopex(@_, "redo") }
1668 sub pp_goto { loopex(@_, "goto") }
1669 sub pp_dump { loopex(@_, "dump") }
1673 my($op, $cx, $name) = @_;
1674 if (class($op) eq "UNOP") {
1675 # Genuine `-X' filetests are exempt from the LLAFR, but not
1676 # l?stat(); for the sake of clarity, give'em all parens
1677 return $self->maybe_parens_unop($name, $op->first, $cx);
1678 } elsif (class($op) eq "SVOP") {
1679 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1680 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1685 sub pp_lstat { ftst(@_, "lstat") }
1686 sub pp_stat { ftst(@_, "stat") }
1687 sub pp_ftrread { ftst(@_, "-R") }
1688 sub pp_ftrwrite { ftst(@_, "-W") }
1689 sub pp_ftrexec { ftst(@_, "-X") }
1690 sub pp_fteread { ftst(@_, "-r") }
1691 sub pp_ftewrite { ftst(@_, "-w") }
1692 sub pp_fteexec { ftst(@_, "-x") }
1693 sub pp_ftis { ftst(@_, "-e") }
1694 sub pp_fteowned { ftst(@_, "-O") }
1695 sub pp_ftrowned { ftst(@_, "-o") }
1696 sub pp_ftzero { ftst(@_, "-z") }
1697 sub pp_ftsize { ftst(@_, "-s") }
1698 sub pp_ftmtime { ftst(@_, "-M") }
1699 sub pp_ftatime { ftst(@_, "-A") }
1700 sub pp_ftctime { ftst(@_, "-C") }
1701 sub pp_ftsock { ftst(@_, "-S") }
1702 sub pp_ftchr { ftst(@_, "-c") }
1703 sub pp_ftblk { ftst(@_, "-b") }
1704 sub pp_ftfile { ftst(@_, "-f") }
1705 sub pp_ftdir { ftst(@_, "-d") }
1706 sub pp_ftpipe { ftst(@_, "-p") }
1707 sub pp_ftlink { ftst(@_, "-l") }
1708 sub pp_ftsuid { ftst(@_, "-u") }
1709 sub pp_ftsgid { ftst(@_, "-g") }
1710 sub pp_ftsvtx { ftst(@_, "-k") }
1711 sub pp_fttty { ftst(@_, "-t") }
1712 sub pp_fttext { ftst(@_, "-T") }
1713 sub pp_ftbinary { ftst(@_, "-B") }
1715 sub SWAP_CHILDREN () { 1 }
1716 sub ASSIGN () { 2 } # has OP= variant
1717 sub LIST_CONTEXT () { 4 } # Assignment is in list context
1723 my $name = $op->name;
1724 if ($name eq "concat" and $op->first->name eq "concat") {
1725 # avoid spurious `=' -- see comment in pp_concat
1728 if ($name eq "null" and class($op) eq "UNOP"
1729 and $op->first->name =~ /^(and|x?or)$/
1730 and null $op->first->sibling)
1732 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1733 # with a null that's used as the common end point of the two
1734 # flows of control. For precedence purposes, ignore it.
1735 # (COND_EXPRs have these too, but we don't bother with
1736 # their associativity).
1737 return assoc_class($op->first);
1739 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1742 # Left associative operators, like `+', for which
1743 # $a + $b + $c is equivalent to ($a + $b) + $c
1746 %left = ('multiply' => 19, 'i_multiply' => 19,
1747 'divide' => 19, 'i_divide' => 19,
1748 'modulo' => 19, 'i_modulo' => 19,
1750 'add' => 18, 'i_add' => 18,
1751 'subtract' => 18, 'i_subtract' => 18,
1753 'left_shift' => 17, 'right_shift' => 17,
1755 'bit_or' => 12, 'bit_xor' => 12,
1757 'or' => 2, 'xor' => 2,
1761 sub deparse_binop_left {
1763 my($op, $left, $prec) = @_;
1764 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1765 and $left{assoc_class($op)} == $left{assoc_class($left)})
1767 return $self->deparse($left, $prec - .00001);
1769 return $self->deparse($left, $prec);
1773 # Right associative operators, like `=', for which
1774 # $a = $b = $c is equivalent to $a = ($b = $c)
1777 %right = ('pow' => 22,
1778 'sassign=' => 7, 'aassign=' => 7,
1779 'multiply=' => 7, 'i_multiply=' => 7,
1780 'divide=' => 7, 'i_divide=' => 7,
1781 'modulo=' => 7, 'i_modulo=' => 7,
1783 'add=' => 7, 'i_add=' => 7,
1784 'subtract=' => 7, 'i_subtract=' => 7,
1786 'left_shift=' => 7, 'right_shift=' => 7,
1788 'bit_or=' => 7, 'bit_xor=' => 7,
1794 sub deparse_binop_right {
1796 my($op, $right, $prec) = @_;
1797 if ($right{assoc_class($op)} && $right{assoc_class($right)}
1798 and $right{assoc_class($op)} == $right{assoc_class($right)})
1800 return $self->deparse($right, $prec - .00001);
1802 return $self->deparse($right, $prec);
1808 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1809 my $left = $op->first;
1810 my $right = $op->last;
1812 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1816 if ($flags & SWAP_CHILDREN) {
1817 ($left, $right) = ($right, $left);
1819 $left = $self->deparse_binop_left($op, $left, $prec);
1820 $left = "($left)" if $flags & LIST_CONTEXT && $left =~ /^\$/;
1821 $right = $self->deparse_binop_right($op, $right, $prec);
1822 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1825 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1826 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1827 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1828 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1829 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1830 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1831 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1832 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1833 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1834 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1835 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1837 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1838 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1839 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1840 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1841 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1843 sub pp_eq { binop(@_, "==", 14) }
1844 sub pp_ne { binop(@_, "!=", 14) }
1845 sub pp_lt { binop(@_, "<", 15) }
1846 sub pp_gt { binop(@_, ">", 15) }
1847 sub pp_ge { binop(@_, ">=", 15) }
1848 sub pp_le { binop(@_, "<=", 15) }
1849 sub pp_ncmp { binop(@_, "<=>", 14) }
1850 sub pp_i_eq { binop(@_, "==", 14) }
1851 sub pp_i_ne { binop(@_, "!=", 14) }
1852 sub pp_i_lt { binop(@_, "<", 15) }
1853 sub pp_i_gt { binop(@_, ">", 15) }
1854 sub pp_i_ge { binop(@_, ">=", 15) }
1855 sub pp_i_le { binop(@_, "<=", 15) }
1856 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1858 sub pp_seq { binop(@_, "eq", 14) }
1859 sub pp_sne { binop(@_, "ne", 14) }
1860 sub pp_slt { binop(@_, "lt", 15) }
1861 sub pp_sgt { binop(@_, "gt", 15) }
1862 sub pp_sge { binop(@_, "ge", 15) }
1863 sub pp_sle { binop(@_, "le", 15) }
1864 sub pp_scmp { binop(@_, "cmp", 14) }
1866 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1867 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
1869 # `.' is special because concats-of-concats are optimized to save copying
1870 # by making all but the first concat stacked. The effect is as if the
1871 # programmer had written `($a . $b) .= $c', except legal.
1872 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1876 my $left = $op->first;
1877 my $right = $op->last;
1880 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1884 $left = $self->deparse_binop_left($op, $left, $prec);
1885 $right = $self->deparse_binop_right($op, $right, $prec);
1886 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1889 # `x' is weird when the left arg is a list
1893 my $left = $op->first;
1894 my $right = $op->last;
1897 if ($op->flags & OPf_STACKED) {
1901 if (null($right)) { # list repeat; count is inside left-side ex-list
1902 my $kid = $left->first->sibling; # skip pushmark
1904 for (; !null($kid->sibling); $kid = $kid->sibling) {
1905 push @exprs, $self->deparse($kid, 6);
1908 $left = "(" . join(", ", @exprs). ")";
1910 $left = $self->deparse_binop_left($op, $left, $prec);
1912 $right = $self->deparse_binop_right($op, $right, $prec);
1913 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1918 my ($op, $cx, $type) = @_;
1919 my $left = $op->first;
1920 my $right = $left->sibling;
1921 $left = $self->deparse($left, 9);
1922 $right = $self->deparse($right, 9);
1923 return $self->maybe_parens("$left $type $right", $cx, 9);
1929 my $flip = $op->first;
1930 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1931 return $self->range($flip->first, $cx, $type);
1934 # one-line while/until is handled in pp_leave
1938 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1939 my $left = $op->first;
1940 my $right = $op->first->sibling;
1941 if ($cx == 0 and is_scope($right) and $blockname
1942 and $self->{'expand'} < 7)
1944 $left = $self->deparse($left, 1);
1945 $right = $self->deparse($right, 0);
1946 return "$blockname ($left) {\n\t$right\n\b}\cK";
1947 } elsif ($cx == 0 and $blockname and not $self->{'parens'}
1948 and $self->{'expand'} < 7) { # $b if $a
1949 $right = $self->deparse($right, 1);
1950 $left = $self->deparse($left, 1);
1951 return "$right $blockname $left";
1952 } elsif ($cx > $lowprec and $highop) { # $a && $b
1953 $left = $self->deparse_binop_left($op, $left, $highprec);
1954 $right = $self->deparse_binop_right($op, $right, $highprec);
1955 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1956 } else { # $a and $b
1957 $left = $self->deparse_binop_left($op, $left, $lowprec);
1958 $right = $self->deparse_binop_right($op, $right, $lowprec);
1959 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1963 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1964 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1966 # xor is syntactically a logop, but it's really a binop (contrary to
1967 # old versions of opcode.pl). Syntax is what matters here.
1968 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1972 my ($op, $cx, $opname) = @_;
1973 my $left = $op->first;
1974 my $right = $op->first->sibling->first; # skip sassign
1975 $left = $self->deparse($left, 7);
1976 $right = $self->deparse($right, 7);
1977 return $self->maybe_parens("$left $opname $right", $cx, 7);
1980 sub pp_andassign { logassignop(@_, "&&=") }
1981 sub pp_orassign { logassignop(@_, "||=") }
1985 my($op, $cx, $name) = @_;
1987 my $parens = ($cx >= 5) || $self->{'parens'};
1988 my $kid = $op->first->sibling;
1989 return $name if null $kid;
1991 if (defined prototype("CORE::$name")
1992 && prototype("CORE::$name") =~ /^;?\*/
1993 && $kid->name eq "rv2gv") {
1994 $first = $self->deparse($kid->first, 6);
1997 $first = $self->deparse($kid, 6);
1999 if ($name eq "chmod" && $first =~ /^\d+$/) {
2000 $first = sprintf("%#o", $first);
2002 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
2003 push @exprs, $first;
2004 $kid = $kid->sibling;
2005 for (; !null($kid); $kid = $kid->sibling) {
2006 push @exprs, $self->deparse($kid, 6);
2009 return "$name(" . join(", ", @exprs) . ")";
2011 return "$name " . join(", ", @exprs);
2015 sub pp_bless { listop(@_, "bless") }
2016 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
2017 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
2018 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
2019 sub pp_index { maybe_targmy(@_, \&listop, "index") }
2020 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
2021 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
2022 sub pp_formline { listop(@_, "formline") } # see also deparse_format
2023 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
2024 sub pp_unpack { listop(@_, "unpack") }
2025 sub pp_pack { listop(@_, "pack") }
2026 sub pp_join { maybe_targmy(@_, \&listop, "join") }
2027 sub pp_splice { listop(@_, "splice") }
2028 sub pp_push { maybe_targmy(@_, \&listop, "push") }
2029 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
2030 sub pp_reverse { listop(@_, "reverse") }
2031 sub pp_warn { listop(@_, "warn") }
2032 sub pp_die { listop(@_, "die") }
2033 # Actually, return is exempt from the LLAFR (see examples in this very
2034 # module!), but for consistency's sake, ignore that fact
2035 sub pp_return { listop(@_, "return") }
2036 sub pp_open { listop(@_, "open") }
2037 sub pp_pipe_op { listop(@_, "pipe") }
2038 sub pp_tie { listop(@_, "tie") }
2039 sub pp_binmode { listop(@_, "binmode") }
2040 sub pp_dbmopen { listop(@_, "dbmopen") }
2041 sub pp_sselect { listop(@_, "select") }
2042 sub pp_select { listop(@_, "select") }
2043 sub pp_read { listop(@_, "read") }
2044 sub pp_sysopen { listop(@_, "sysopen") }
2045 sub pp_sysseek { listop(@_, "sysseek") }
2046 sub pp_sysread { listop(@_, "sysread") }
2047 sub pp_syswrite { listop(@_, "syswrite") }
2048 sub pp_send { listop(@_, "send") }
2049 sub pp_recv { listop(@_, "recv") }
2050 sub pp_seek { listop(@_, "seek") }
2051 sub pp_fcntl { listop(@_, "fcntl") }
2052 sub pp_ioctl { listop(@_, "ioctl") }
2053 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
2054 sub pp_socket { listop(@_, "socket") }
2055 sub pp_sockpair { listop(@_, "sockpair") }
2056 sub pp_bind { listop(@_, "bind") }
2057 sub pp_connect { listop(@_, "connect") }
2058 sub pp_listen { listop(@_, "listen") }
2059 sub pp_accept { listop(@_, "accept") }
2060 sub pp_shutdown { listop(@_, "shutdown") }
2061 sub pp_gsockopt { listop(@_, "getsockopt") }
2062 sub pp_ssockopt { listop(@_, "setsockopt") }
2063 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
2064 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
2065 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
2066 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
2067 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
2068 sub pp_link { maybe_targmy(@_, \&listop, "link") }
2069 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
2070 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
2071 sub pp_open_dir { listop(@_, "opendir") }
2072 sub pp_seekdir { listop(@_, "seekdir") }
2073 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
2074 sub pp_system { maybe_targmy(@_, \&listop, "system") }
2075 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
2076 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
2077 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
2078 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
2079 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
2080 sub pp_shmget { listop(@_, "shmget") }
2081 sub pp_shmctl { listop(@_, "shmctl") }
2082 sub pp_shmread { listop(@_, "shmread") }
2083 sub pp_shmwrite { listop(@_, "shmwrite") }
2084 sub pp_msgget { listop(@_, "msgget") }
2085 sub pp_msgctl { listop(@_, "msgctl") }
2086 sub pp_msgsnd { listop(@_, "msgsnd") }
2087 sub pp_msgrcv { listop(@_, "msgrcv") }
2088 sub pp_semget { listop(@_, "semget") }
2089 sub pp_semctl { listop(@_, "semctl") }
2090 sub pp_semop { listop(@_, "semop") }
2091 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
2092 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
2093 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
2094 sub pp_gsbyname { listop(@_, "getservbyname") }
2095 sub pp_gsbyport { listop(@_, "getservbyport") }
2096 sub pp_syscall { listop(@_, "syscall") }
2101 my $text = $self->dq($op->first->sibling); # skip pushmark
2102 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
2103 or $text =~ /[<>]/) {
2104 return 'glob(' . single_delim('qq', '"', $text) . ')';
2106 return '<' . $text . '>';
2110 # Truncate is special because OPf_SPECIAL makes a bareword first arg
2111 # be a filehandle. This could probably be better fixed in the core
2112 # by moving the GV lookup into ck_truc.
2118 my $parens = ($cx >= 5) || $self->{'parens'};
2119 my $kid = $op->first->sibling;
2121 if ($op->flags & OPf_SPECIAL) {
2122 # $kid is an OP_CONST
2123 $fh = $self->const_sv($kid)->PV;
2125 $fh = $self->deparse($kid, 6);
2126 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
2128 my $len = $self->deparse($kid->sibling, 6);
2130 return "truncate($fh, $len)";
2132 return "truncate $fh, $len";
2138 my($op, $cx, $name) = @_;
2140 my $kid = $op->first->sibling;
2142 if ($op->flags & OPf_STACKED) {
2144 $indir = $indir->first; # skip rv2gv
2145 if (is_scope($indir)) {
2146 $indir = "{" . $self->deparse($indir, 0) . "}";
2147 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
2148 $indir = $self->const_sv($indir)->PV;
2150 $indir = $self->deparse($indir, 24);
2152 $indir = $indir . " ";
2153 $kid = $kid->sibling;
2155 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
2156 $indir = ($op->private & OPpSORT_REVERSE) ? '{$b <=> $a} '
2159 elsif ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
2160 $indir = '{$b cmp $a} ';
2162 for (; !null($kid); $kid = $kid->sibling) {
2163 $expr = $self->deparse($kid, 6);
2166 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
2170 sub pp_prtf { indirop(@_, "printf") }
2171 sub pp_print { indirop(@_, "print") }
2172 sub pp_sort { indirop(@_, "sort") }
2176 my($op, $cx, $name) = @_;
2178 my $kid = $op->first; # this is the (map|grep)start
2179 $kid = $kid->first->sibling; # skip a pushmark
2180 my $code = $kid->first; # skip a null
2181 if (is_scope $code) {
2182 $code = "{" . $self->deparse($code, 0) . "} ";
2184 $code = $self->deparse($code, 24) . ", ";
2186 $kid = $kid->sibling;
2187 for (; !null($kid); $kid = $kid->sibling) {
2188 $expr = $self->deparse($kid, 6);
2189 push @exprs, $expr if $expr;
2191 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2194 sub pp_mapwhile { mapop(@_, "map") }
2195 sub pp_grepwhile { mapop(@_, "grep") }
2201 my $kid = $op->first->sibling; # skip pushmark
2203 my $local = "either"; # could be local(...), my(...) or our(...)
2204 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2205 # This assumes that no other private flags equal 128, and that
2206 # OPs that store things other than flags in their op_private,
2207 # like OP_AELEMFAST, won't be immediate children of a list.
2208 unless ($lop->private & OPpLVAL_INTRO
2209 or $lop->name eq "undef")
2211 $local = ""; # or not
2214 if ($lop->name =~ /^pad[ash]v$/) { # my()
2215 ($local = "", last) if $local eq "local" || $local eq "our";
2217 } elsif ($op->name =~ /^(gv|rv2)[ash]v$/
2218 && $op->private & OPpOUR_INTRO) { # our()
2219 ($local = "", last) if $local eq "my" || $local eq "local";
2221 } elsif ($lop->name ne "undef") { # local()
2222 ($local = "", last) if $local eq "my" || $local eq "our";
2226 $local = "" if $local eq "either"; # no point if it's all undefs
2227 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2228 for (; !null($kid); $kid = $kid->sibling) {
2230 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2235 $self->{'avoid_local'}{$$lop}++;
2236 $expr = $self->deparse($kid, 6);
2237 delete $self->{'avoid_local'}{$$lop};
2239 $expr = $self->deparse($kid, 6);
2244 return "$local(" . join(", ", @exprs) . ")";
2246 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2250 sub is_ifelse_cont {
2252 return ($op->name eq "null" and class($op) eq "UNOP"
2253 and $op->first->name =~ /^(and|cond_expr)$/
2254 and is_scope($op->first->first->sibling));
2260 my $cond = $op->first;
2261 my $true = $cond->sibling;
2262 my $false = $true->sibling;
2263 my $cuddle = $self->{'cuddle'};
2264 unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
2265 (is_scope($false) || is_ifelse_cont($false))
2266 and $self->{'expand'} < 7) {
2267 $cond = $self->deparse($cond, 8);
2268 $true = $self->deparse($true, 8);
2269 $false = $self->deparse($false, 8);
2270 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2273 $cond = $self->deparse($cond, 1);
2274 $true = $self->deparse($true, 0);
2275 my $head = "if ($cond) {\n\t$true\n\b}";
2277 while (!null($false) and is_ifelse_cont($false)) {
2278 my $newop = $false->first;
2279 my $newcond = $newop->first;
2280 my $newtrue = $newcond->sibling;
2281 $false = $newtrue->sibling; # last in chain is OP_AND => no else
2282 $newcond = $self->deparse($newcond, 1);
2283 $newtrue = $self->deparse($newtrue, 0);
2284 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2286 if (!null($false)) {
2287 $false = $cuddle . "else {\n\t" .
2288 $self->deparse($false, 0) . "\n\b}\cK";
2292 return $head . join($cuddle, "", @elsifs) . $false;
2297 my($op, $cx, $init) = @_;
2298 my $enter = $op->first;
2299 my $kid = $enter->sibling;
2300 local(@$self{qw'curstash warnings hints'})
2301 = @$self{qw'curstash warnings hints'};
2306 if ($kid->name eq "lineseq") { # bare or infinite loop
2307 if (is_state $kid->last) { # infinite
2308 $head = "while (1) "; # Can't use for(;;) if there's a continue
2314 } elsif ($enter->name eq "enteriter") { # foreach
2315 my $ary = $enter->first->sibling; # first was pushmark
2316 my $var = $ary->sibling;
2317 if ($enter->flags & OPf_STACKED
2318 and not null $ary->first->sibling->sibling)
2320 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2321 $self->deparse($ary->first->sibling->sibling, 9);
2323 $ary = $self->deparse($ary, 1);
2326 if ($enter->flags & OPf_SPECIAL) { # thread special var
2327 $var = $self->pp_threadsv($enter, 1);
2328 } else { # regular my() variable
2329 $var = $self->pp_padsv($enter, 1);
2330 if ($self->padname_sv($enter->targ)->IVX ==
2331 $kid->first->first->sibling->last->cop_seq)
2333 # If the scope of this variable closes at the last
2334 # statement of the loop, it must have been
2336 $var = "my " . $var;
2339 } elsif ($var->name eq "rv2gv") {
2340 $var = $self->pp_rv2sv($var, 1);
2341 } elsif ($var->name eq "gv") {
2342 $var = "\$" . $self->deparse($var, 1);
2344 $head = "foreach $var ($ary) ";
2345 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2346 } elsif ($kid->name eq "null") { # while/until
2348 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2349 $cond = $self->deparse($kid->first, 1);
2350 $head = "$name ($cond) ";
2351 $body = $kid->first->sibling;
2352 } elsif ($kid->name eq "stub") { # bare and empty
2353 return "{;}"; # {} could be a hashref
2355 # If there isn't a continue block, then the next pointer for the loop
2356 # will point to the unstack, which is kid's penultimate child, except
2357 # in a bare loop, when it will point to the leaveloop. When neither of
2358 # these conditions hold, then the third-to-last child in the continue
2359 # block (or the last in a bare loop).
2360 my $cont_start = $enter->nextop;
2362 if ($$cont_start != $$op && ${$cont_start->sibling} != ${$body->last}) {
2364 $cont = $body->last;
2366 $cont = $body->first;
2367 while (!null($cont->sibling->sibling->sibling)) {
2368 $cont = $cont->sibling;
2371 my $state = $body->first;
2372 my $cuddle = $self->{'cuddle'};
2374 for (; $$state != $$cont; $state = $state->sibling) {
2375 push @states, $state;
2377 $body = $self->lineseq(undef, @states);
2378 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2379 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2382 $cont = $cuddle . "continue {\n\t" .
2383 $self->deparse($cont, 0) . "\n\b}\cK";
2386 return "" if !defined $body;
2388 $head = "for ($init; $cond;) ";
2391 $body = $self->deparse($body, 0);
2393 $body =~ s/;?$/;\n/;
2395 return $head . "{\n\t" . $body . "\b}" . $cont;
2398 sub pp_leaveloop { loop_common(@_, "") }
2403 my $init = $self->deparse($op, 1);
2404 return $self->loop_common($op->sibling->first->sibling, $cx, $init);
2409 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2412 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2413 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2418 if (class($op) eq "OP") {
2420 return $self->{'ex_const'} if $op->targ == OP_CONST;
2421 } elsif ($op->first->name eq "pushmark") {
2422 return $self->pp_list($op, $cx);
2423 } elsif ($op->first->name eq "enter") {
2424 return $self->pp_leave($op, $cx);
2425 } elsif ($op->targ == OP_STRINGIFY) {
2426 return $self->dquote($op, $cx);
2427 } elsif (!null($op->first->sibling) and
2428 $op->first->sibling->name eq "readline" and
2429 $op->first->sibling->flags & OPf_STACKED) {
2430 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2431 . $self->deparse($op->first->sibling, 7),
2433 } elsif (!null($op->first->sibling) and
2434 $op->first->sibling->name eq "trans" and
2435 $op->first->sibling->flags & OPf_STACKED) {
2436 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2437 . $self->deparse($op->first->sibling, 20),
2439 } elsif ($op->flags & OPf_SPECIAL && $cx == 0 && !$op->targ) {
2440 return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
2442 return $self->deparse($op->first, $cx);
2449 return $self->padname_sv($targ)->PVX;
2455 return substr($self->padname($op->targ), 1); # skip $/@/%
2461 return $self->maybe_my($op, $cx, $self->padname($op->targ));
2464 sub pp_padav { pp_padsv(@_) }
2465 sub pp_padhv { pp_padsv(@_) }
2470 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2471 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2472 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2479 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
2485 if (class($op) eq "PADOP") {
2486 return $self->padval($op->padix);
2487 } else { # class($op) eq "SVOP"
2495 my $gv = $self->gv_or_padgv($op);
2496 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2497 $self->gv_name($gv)));
2503 my $gv = $self->gv_or_padgv($op);
2504 return $self->gv_name($gv);
2510 my $gv = $self->gv_or_padgv($op);
2511 my $name = $self->gv_name($gv);
2512 $name = $self->{'curstash'}."::$name"
2513 if $name !~ /::/ && $self->lex_in_scope('@'.$name);
2515 return "\$" . $name . "[" .
2516 ($op->private + $self->{'arybase'}) . "]";
2521 my($op, $cx, $type) = @_;
2522 my $kid = $op->first;
2523 my $str = $self->deparse($kid, 0);
2524 return $self->stash_variable($type, $str) if is_scalar($kid);
2525 return $type ."{$str}";
2528 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2529 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2530 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2536 if ($op->first->name eq "padav") {
2537 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2539 return $self->maybe_local($op, $cx,
2540 $self->rv2x($op->first, $cx, '$#'));
2544 # skip down to the old, ex-rv2cv
2545 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
2550 my $kid = $op->first;
2551 if ($kid->name eq "const") { # constant list
2552 my $av = $self->const_sv($kid);
2553 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2555 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2559 sub is_subscriptable {
2561 if ($op->name =~ /^[ahg]elem/) {
2563 } elsif ($op->name eq "entersub") {
2564 my $kid = $op->first;
2565 return 0 unless null $kid->sibling;
2567 $kid = $kid->sibling until null $kid->sibling;
2568 return 0 if is_scope($kid);
2570 return 0 if $kid->name eq "gv";
2571 return 0 if is_scalar($kid);
2572 return is_subscriptable($kid);
2580 my ($op, $cx, $left, $right, $padname) = @_;
2581 my($array, $idx) = ($op->first, $op->first->sibling);
2582 unless ($array->name eq $padname) { # Maybe this has been fixed
2583 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2585 if ($array->name eq $padname) {
2586 $array = $self->padany($array);
2587 } elsif (is_scope($array)) { # ${expr}[0]
2588 $array = "{" . $self->deparse($array, 0) . "}";
2589 } elsif ($array->name eq "gv") {
2590 $array = $self->gv_name($self->gv_or_padgv($array));
2591 if ($array !~ /::/) {
2592 my $prefix = ($left eq '[' ? '@' : '%');
2593 $array = $self->{curstash}.'::'.$array
2594 if $self->lex_in_scope($prefix . $array);
2596 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2597 $array = $self->deparse($array, 24);
2599 # $x[20][3]{hi} or expr->[20]
2600 my $arrow = is_subscriptable($array) ? "" : "->";
2601 return $self->deparse($array, 24) . $arrow .
2602 $left . $self->deparse($idx, 1) . $right;
2604 $idx = $self->deparse($idx, 1);
2606 # Outer parens in an array index will confuse perl
2607 # if we're interpolating in a regular expression, i.e.
2608 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2610 # If $self->{parens}, then an initial '(' will
2611 # definitely be paired with a final ')'. If
2612 # !$self->{parens}, the misleading parens won't
2613 # have been added in the first place.
2615 # [You might think that we could get "(...)...(...)"
2616 # where the initial and final parens do not match
2617 # each other. But we can't, because the above would
2618 # only happen if there's an infix binop between the
2619 # two pairs of parens, and *that* means that the whole
2620 # expression would be parenthesized as well.]
2622 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2624 return "\$" . $array . $left . $idx . $right;
2627 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2628 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2633 my($glob, $part) = ($op->first, $op->last);
2634 $glob = $glob->first; # skip rv2gv
2635 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2636 my $scope = is_scope($glob);
2637 $glob = $self->deparse($glob, 0);
2638 $part = $self->deparse($part, 1);
2639 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2644 my ($op, $cx, $left, $right, $regname, $padname) = @_;
2646 my(@elems, $kid, $array, $list);
2647 if (class($op) eq "LISTOP") {
2649 } else { # ex-hslice inside delete()
2650 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2654 $array = $array->first
2655 if $array->name eq $regname or $array->name eq "null";
2656 if (is_scope($array)) {
2657 $array = "{" . $self->deparse($array, 0) . "}";
2658 } elsif ($array->name eq $padname) {
2659 $array = $self->padany($array);
2661 $array = $self->deparse($array, 24);
2663 $kid = $op->first->sibling; # skip pushmark
2664 if ($kid->name eq "list") {
2665 $kid = $kid->first->sibling; # skip list, pushmark
2666 for (; !null $kid; $kid = $kid->sibling) {
2667 push @elems, $self->deparse($kid, 6);
2669 $list = join(", ", @elems);
2671 $list = $self->deparse($kid, 1);
2673 return "\@" . $array . $left . $list . $right;
2676 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2677 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2682 my $idx = $op->first;
2683 my $list = $op->last;
2685 $list = $self->deparse($list, 1);
2686 $idx = $self->deparse($idx, 1);
2687 return "($list)" . "[$idx]";
2692 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2697 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2703 my $kid = $op->first->sibling; # skip pushmark
2704 my($meth, $obj, @exprs);
2705 if ($kid->name eq "list" and want_list $kid) {
2706 # When an indirect object isn't a bareword but the args are in
2707 # parens, the parens aren't part of the method syntax (the LLAFR
2708 # doesn't apply), but they make a list with OPf_PARENS set that
2709 # doesn't get flattened by the append_elem that adds the method,
2710 # making a (object, arg1, arg2, ...) list where the object
2711 # usually is. This can be distinguished from
2712 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2713 # object) because in the later the list is in scalar context
2714 # as the left side of -> always is, while in the former
2715 # the list is in list context as method arguments always are.
2716 # (Good thing there aren't method prototypes!)
2717 $meth = $kid->sibling;
2718 $kid = $kid->first->sibling; # skip pushmark
2720 $kid = $kid->sibling;
2721 for (; not null $kid; $kid = $kid->sibling) {
2722 push @exprs, $self->deparse($kid, 6);
2726 $kid = $kid->sibling;
2727 for (; not null $kid->sibling; $kid = $kid->sibling) {
2728 push @exprs, $self->deparse($kid, 6);
2732 $obj = $self->deparse($obj, 24);
2733 if ($meth->name eq "method_named") {
2734 $meth = $self->const_sv($meth)->PV;
2736 $meth = $meth->first;
2737 if ($meth->name eq "const") {
2738 # As of 5.005_58, this case is probably obsoleted by the
2739 # method_named case above
2740 $meth = $self->const_sv($meth)->PV; # needs to be bare
2742 $meth = $self->deparse($meth, 1);
2745 my $args = join(", ", @exprs);
2746 $kid = $obj . "->" . $meth;
2748 return $kid . "(" . $args . ")"; # parens mandatory
2754 # returns "&" if the prototype doesn't match the args,
2755 # or ("", $args_after_prototype_demunging) if it does.
2758 my($proto, @args) = @_;
2762 # An unbackslashed @ or % gobbles up the rest of the args
2763 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2765 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2768 return "&" if @args;
2769 } elsif ($chr eq ";") {
2771 } elsif ($chr eq "@" or $chr eq "%") {
2772 push @reals, map($self->deparse($_, 6), @args);
2778 if (want_scalar $arg) {
2779 push @reals, $self->deparse($arg, 6);
2783 } elsif ($chr eq "&") {
2784 if ($arg->name =~ /^(s?refgen|undef)$/) {
2785 push @reals, $self->deparse($arg, 6);
2789 } elsif ($chr eq "*") {
2790 if ($arg->name =~ /^s?refgen$/
2791 and $arg->first->first->name eq "rv2gv")
2793 $real = $arg->first->first; # skip refgen, null
2794 if ($real->first->name eq "gv") {
2795 push @reals, $self->deparse($real, 6);
2797 push @reals, $self->deparse($real->first, 6);
2802 } elsif (substr($chr, 0, 1) eq "\\") {
2803 $chr = substr($chr, 1);
2804 if ($arg->name =~ /^s?refgen$/ and
2805 !null($real = $arg->first) and
2806 ($chr eq "\$" && is_scalar($real->first)
2808 && $real->first->sibling->name
2811 && $real->first->sibling->name
2813 #or ($chr eq "&" # This doesn't work
2814 # && $real->first->name eq "rv2cv")
2816 && $real->first->name eq "rv2gv")))
2818 push @reals, $self->deparse($real, 6);
2825 return "&" if $proto and !$doneok; # too few args and no `;'
2826 return "&" if @args; # too many args
2827 return ("", join ", ", @reals);
2833 return $self->method($op, $cx) unless null $op->first->sibling;
2837 if ($op->flags & OPf_SPECIAL) {
2839 } elsif ($op->private & OPpENTERSUB_AMPER) {
2843 $kid = $kid->first->sibling; # skip ex-list, pushmark
2844 for (; not null $kid->sibling; $kid = $kid->sibling) {
2849 if (is_scope($kid)) {
2851 $kid = "{" . $self->deparse($kid, 0) . "}";
2852 } elsif ($kid->first->name eq "gv") {
2853 my $gv = $self->gv_or_padgv($kid->first);
2854 if (class($gv->CV) ne "SPECIAL") {
2855 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2857 $simple = 1; # only calls of named functions can be prototyped
2858 $kid = $self->deparse($kid, 24);
2859 } elsif (is_scalar $kid->first) {
2861 $kid = $self->deparse($kid, 24);
2864 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2865 $kid = $self->deparse($kid, 24) . $arrow;
2868 # Doesn't matter how many prototypes there are, if
2869 # they haven't happened yet!
2870 my $declared = exists $self->{'subs_declared'}{$kid};
2871 if (!$declared && defined($proto)) {
2872 # Avoid "too early to check prototype" warning
2873 ($amper, $proto) = ('&');
2877 if ($declared and defined $proto and not $amper) {
2878 ($amper, $args) = $self->check_proto($proto, @exprs);
2879 if ($amper eq "&") {
2880 $args = join(", ", map($self->deparse($_, 6), @exprs));
2883 $args = join(", ", map($self->deparse($_, 6), @exprs));
2885 if ($prefix or $amper) {
2886 if ($op->flags & OPf_STACKED) {
2887 return $prefix . $amper . $kid . "(" . $args . ")";
2889 return $prefix . $amper. $kid;
2892 # glob() invocations can be translated into calls of
2893 # CORE::GLOBAL::glob with an second parameter, a number.
2895 if ($kid eq "CORE::GLOBAL::glob") {
2897 $args =~ s/\s*,[^,]+$//;
2900 # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
2901 # so it must have been translated from a keyword call. Translate
2903 $kid =~ s/^CORE::GLOBAL:://;
2906 return "$kid(" . $args . ")";
2907 } elsif (defined $proto and $proto eq "") {
2909 } elsif (defined $proto and $proto eq "\$" and is_scalar($exprs[0])) {
2910 return $self->maybe_parens_func($kid, $args, $cx, 16);
2911 } elsif (defined($proto) && $proto or $simple) {
2912 return $self->maybe_parens_func($kid, $args, $cx, 5);
2914 return "$kid(" . $args . ")";
2919 sub pp_enterwrite { unop(@_, "write") }
2921 # escape things that cause interpolation in double quotes,
2922 # but not character escapes
2925 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
2929 # the same, but treat $|, $), $( and $ at the end of the string differently
2932 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@](?!\||\)|\(|$)|\\[uUlLQE])/$1$2\\$3/g;
2936 # character escapes, but not delimiters that might need to be escaped
2937 sub escape_str { # ASCII, UTF8
2939 $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
2941 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2947 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2948 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2952 # Don't do this for regexen
2955 $str =~ s/\\/\\\\/g;
2959 # Remove backslashes which precede literal control characters,
2960 # to avoid creating ambiguity when we escape the latter.
2964 # the insane complexity here is due to the behaviour of "\c\"
2965 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
2969 sub balanced_delim {
2971 my @str = split //, $str;
2972 my($ar, $open, $close, $fail, $c, $cnt);
2973 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2974 ($open, $close) = @$ar;
2975 $fail = 0; $cnt = 0;
2979 } elsif ($c eq $close) {
2988 $fail = 1 if $cnt != 0;
2989 return ($open, "$open$str$close") if not $fail;
2995 my($q, $default, $str) = @_;
2996 return "$default$str$default" if $default and index($str, $default) == -1;
2997 my($succeed, $delim);
2998 ($succeed, $str) = balanced_delim($str);
2999 return "$q$str" if $succeed;
3000 for $delim ('/', '"', '#') {
3001 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3004 $str =~ s/$default/\\$default/g;
3005 return "$default$str$default";
3014 if (class($sv) eq "SPECIAL") {
3015 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
3016 } elsif (class($sv) eq "NULL") {
3018 } elsif ($sv->FLAGS & SVf_IOK) {
3019 return $sv->int_value;
3020 } elsif ($sv->FLAGS & SVf_NOK) {
3022 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3023 return "\\(" . const($sv->RV) . ")"; # constant folded
3026 if ($str =~ /[^ -~]/) { # ASCII for non-printing
3027 return single_delim("qq", '"', uninterp escape_str unback $str);
3029 return single_delim("q", "'", unback $str);
3038 # the constant could be in the pad (under useithreads)
3039 $sv = $self->padval($op->targ) unless $$sv;
3046 if ($op->private & OPpCONST_ARYBASE) {
3049 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3050 # return $self->const_sv($op)->PV;
3052 my $sv = $self->const_sv($op);
3053 # return const($sv);
3055 return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
3061 my $type = $op->name;
3062 if ($type eq "const") {
3063 return '$[' if $op->private & OPpCONST_ARYBASE;
3064 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3065 } elsif ($type eq "concat") {
3066 my $first = $self->dq($op->first);
3067 my $last = $self->dq($op->last);
3068 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3069 if ($last =~ /^[A-Z\\\^\[\]_?]/) {
3070 $first =~ s/([\$@])\^$/${1}{^}/; # "${^}W" etc
3072 elsif ($last =~ /^[{\[\w]/) {
3073 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
3075 return $first . $last;
3076 } elsif ($type eq "uc") {
3077 return '\U' . $self->dq($op->first->sibling) . '\E';
3078 } elsif ($type eq "lc") {
3079 return '\L' . $self->dq($op->first->sibling) . '\E';
3080 } elsif ($type eq "ucfirst") {
3081 return '\u' . $self->dq($op->first->sibling);
3082 } elsif ($type eq "lcfirst") {
3083 return '\l' . $self->dq($op->first->sibling);
3084 } elsif ($type eq "quotemeta") {
3085 return '\Q' . $self->dq($op->first->sibling) . '\E';
3086 } elsif ($type eq "join") {
3087 return $self->deparse($op->last, 26); # was join($", @ary)
3089 return $self->deparse($op, 26);
3097 return single_delim("qx", '`', $self->dq($op->first->sibling));
3103 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3104 return $self->deparse($kid, $cx) if $self->{'unquote'};
3105 $self->maybe_targmy($kid, $cx,
3106 sub {single_delim("qq", '"', $self->dq($_[1]))});
3109 # OP_STRINGIFY is a listop, but it only ever has one arg
3110 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3112 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3113 # note that tr(from)/to/ is OK, but not tr/from/(to)
3115 my($from, $to) = @_;
3116 my($succeed, $delim);
3117 if ($from !~ m[/] and $to !~ m[/]) {
3118 return "/$from/$to/";
3119 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3120 if (($succeed, $to) = balanced_delim($to) and $succeed) {
3123 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3124 return "$from$delim$to$delim" if index($to, $delim) == -1;
3127 return "$from/$to/";
3130 for $delim ('/', '"', '#') { # note no '
3131 return "$delim$from$delim$to$delim"
3132 if index($to . $from, $delim) == -1;
3134 $from =~ s[/][\\/]g;
3136 return "/$from/$to/";
3142 if ($n == ord '\\') {
3144 } elsif ($n >= ord(' ') and $n <= ord('~')) {
3146 } elsif ($n == ord "\a") {
3148 } elsif ($n == ord "\b") {
3150 } elsif ($n == ord "\t") {
3152 } elsif ($n == ord "\n") {
3154 } elsif ($n == ord "\e") {
3156 } elsif ($n == ord "\f") {
3158 } elsif ($n == ord "\r") {
3160 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3161 return '\\c' . chr(ord("@") + $n);
3163 # return '\x' . sprintf("%02x", $n);
3164 return '\\' . sprintf("%03o", $n);
3170 my($str, $c, $tr) = ("");
3171 for ($c = 0; $c < @chars; $c++) {
3174 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3175 $chars[$c + 2] == $tr + 2)
3177 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3180 $str .= pchr($chars[$c]);
3186 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
3189 sub tr_decode_byte {
3190 my($table, $flags) = @_;
3191 my(@table) = unpack("s256", $table);
3192 my($c, $tr, @from, @to, @delfrom, $delhyphen);
3193 if ($table[ord "-"] != -1 and
3194 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3196 $tr = $table[ord "-"];
3197 $table[ord "-"] = -1;
3201 } else { # -2 ==> delete
3205 for ($c = 0; $c < 256; $c++) {
3208 push @from, $c; push @to, $tr;
3209 } elsif ($tr == -2) {
3213 @from = (@from, @delfrom);
3214 if ($flags & OPpTRANS_COMPLEMENT) {
3217 @from{@from} = (1) x @from;
3218 for ($c = 0; $c < 256; $c++) {
3219 push @newfrom, $c unless $from{$c};
3223 unless ($flags & OPpTRANS_DELETE || !@to) {
3224 pop @to while $#to and $to[$#to] == $to[$#to -1];
3227 $from = collapse(@from);
3228 $to = collapse(@to);
3229 $from .= "-" if $delhyphen;
3230 return ($from, $to);
3235 if ($x == ord "-") {
3242 # XXX This doesn't yet handle all cases correctly either
3244 sub tr_decode_utf8 {
3245 my($swash_hv, $flags) = @_;
3246 my %swash = $swash_hv->ARRAY;
3248 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3249 my $none = $swash{"NONE"}->IV;
3250 my $extra = $none + 1;
3251 my(@from, @delfrom, @to);
3253 foreach $line (split /\n/, $swash{'LIST'}->PV) {
3254 my($min, $max, $result) = split(/\t/, $line);
3261 $result = hex $result;
3262 if ($result == $extra) {
3263 push @delfrom, [$min, $max];
3265 push @from, [$min, $max];
3266 push @to, [$result, $result + $max - $min];
3269 for my $i (0 .. $#from) {
3270 if ($from[$i][0] == ord '-') {
3271 unshift @from, splice(@from, $i, 1);
3272 unshift @to, splice(@to, $i, 1);
3274 } elsif ($from[$i][1] == ord '-') {
3277 unshift @from, ord '-';
3278 unshift @to, ord '-';
3282 for my $i (0 .. $#delfrom) {
3283 if ($delfrom[$i][0] == ord '-') {
3284 push @delfrom, splice(@delfrom, $i, 1);
3286 } elsif ($delfrom[$i][1] == ord '-') {
3288 push @delfrom, ord '-';
3292 if (defined $final and $to[$#to][1] != $final) {
3293 push @to, [$final, $final];
3295 push @from, @delfrom;
3296 if ($flags & OPpTRANS_COMPLEMENT) {
3299 for my $i (0 .. $#from) {
3300 push @newfrom, [$next, $from[$i][0] - 1];
3301 $next = $from[$i][1] + 1;
3304 for my $range (@newfrom) {
3305 if ($range->[0] <= $range->[1]) {
3310 my($from, $to, $diff);
3311 for my $chunk (@from) {
3312 $diff = $chunk->[1] - $chunk->[0];
3314 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3315 } elsif ($diff == 1) {
3316 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3318 $from .= tr_chr($chunk->[0]);
3321 for my $chunk (@to) {
3322 $diff = $chunk->[1] - $chunk->[0];
3324 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3325 } elsif ($diff == 1) {
3326 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3328 $to .= tr_chr($chunk->[0]);
3331 #$final = sprintf("%04x", $final) if defined $final;
3332 #$none = sprintf("%04x", $none) if defined $none;
3333 #$extra = sprintf("%04x", $extra) if defined $extra;
3334 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3335 #print STDERR $swash{'LIST'}->PV;
3336 return (escape_str($from), escape_str($to));
3343 if (class($op) eq "PVOP") {
3344 ($from, $to) = tr_decode_byte($op->pv, $op->private);
3345 } else { # class($op) eq "SVOP"
3346 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3349 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3350 $flags .= "d" if $op->private & OPpTRANS_DELETE;
3351 $to = "" if $from eq $to and $flags eq "";
3352 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3353 return "tr" . double_delim($from, $to) . $flags;
3356 # Like dq(), but different
3360 my $type = $op->name;
3361 if ($type eq "const") {
3362 return '$[' if $op->private & OPpCONST_ARYBASE;
3363 return re_uninterp(escape_str(re_unback($self->const_sv($op)->as_string)));
3364 } elsif ($type eq "concat") {
3365 my $first = $self->re_dq($op->first);
3366 my $last = $self->re_dq($op->last);
3367 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3368 if ($last =~ /^[A-Z\\\^\[\]_?]/) {
3369 $first =~ s/([\$@])\^$/${1}{^}/;
3371 elsif ($last =~ /^[{\[\w]/) {
3372 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
3374 return $first . $last;
3375 } elsif ($type eq "uc") {
3376 return '\U' . $self->re_dq($op->first->sibling) . '\E';
3377 } elsif ($type eq "lc") {
3378 return '\L' . $self->re_dq($op->first->sibling) . '\E';
3379 } elsif ($type eq "ucfirst") {
3380 return '\u' . $self->re_dq($op->first->sibling);
3381 } elsif ($type eq "lcfirst") {
3382 return '\l' . $self->re_dq($op->first->sibling);
3383 } elsif ($type eq "quotemeta") {
3384 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
3385 } elsif ($type eq "join") {
3386 return $self->deparse($op->last, 26); # was join($", @ary)
3388 return $self->deparse($op, 26);
3395 my $kid = $op->first;
3396 $kid = $kid->first if $kid->name eq "regcmaybe";
3397 $kid = $kid->first if $kid->name eq "regcreset";
3398 return $self->re_dq($kid);
3401 # osmic acid -- see osmium tetroxide
3404 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3405 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3406 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3410 my($op, $cx, $name, $delim) = @_;
3411 my $kid = $op->first;
3412 my ($binop, $var, $re) = ("", "", "");
3413 if ($op->flags & OPf_STACKED) {
3415 $var = $self->deparse($kid, 20);
3416 $kid = $kid->sibling;
3419 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3421 $re = $self->deparse($kid, 1);
3424 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3425 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3426 $flags .= "i" if $op->pmflags & PMf_FOLD;
3427 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3428 $flags .= "o" if $op->pmflags & PMf_KEEP;
3429 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3430 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3431 $flags = $matchwords{$flags} if $matchwords{$flags};
3432 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3436 $re = single_delim($name, $delim, $re);
3440 return $self->maybe_parens("$var =~ $re", $cx, 20);
3446 sub pp_match { matchop(@_, "m", "/") }
3447 sub pp_pushre { matchop(@_, "m", "/") }
3448 sub pp_qr { matchop(@_, "qr", "") }
3453 my($kid, @exprs, $ary, $expr);
3455 if ($ {$kid->pmreplroot}) {
3456 $ary = $self->stash_variable('@', $self->gv_name($kid->pmreplroot));
3458 for (; !null($kid); $kid = $kid->sibling) {
3459 push @exprs, $self->deparse($kid, 6);
3462 # handle special case of split(), and split(" ") that compiles to /\s+/
3464 if ($kid->flags & OPf_SPECIAL
3465 && $exprs[0] eq '/\\s+/'
3466 && $kid->pmflags & PMf_SKIPWHITE ) {
3470 $expr = "split(" . join(", ", @exprs) . ")";
3472 return $self->maybe_parens("$ary = $expr", $cx, 7);
3478 # oxime -- any of various compounds obtained chiefly by the action of
3479 # hydroxylamine on aldehydes and ketones and characterized by the
3480 # bivalent grouping C=NOH [Webster's Tenth]
3483 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3484 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3485 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3486 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3491 my $kid = $op->first;
3492 my($binop, $var, $re, $repl) = ("", "", "", "");
3493 if ($op->flags & OPf_STACKED) {
3495 $var = $self->deparse($kid, 20);
3496 $kid = $kid->sibling;
3499 if (null($op->pmreplroot)) {
3500 $repl = $self->dq($kid);
3501 $kid = $kid->sibling;
3503 $repl = $op->pmreplroot->first; # skip substcont
3504 while ($repl->name eq "entereval") {
3505 $repl = $repl->first;
3508 if ($op->pmflags & PMf_EVAL) {
3509 $repl = $self->deparse($repl, 0);
3511 $repl = $self->dq($repl);
3515 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3517 $re = $self->deparse($kid, 1);
3519 $flags .= "e" if $op->pmflags & PMf_EVAL;
3520 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3521 $flags .= "i" if $op->pmflags & PMf_FOLD;
3522 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3523 $flags .= "o" if $op->pmflags & PMf_KEEP;
3524 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3525 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3526 $flags = $substwords{$flags} if $substwords{$flags};
3528 return $self->maybe_parens("$var =~ s"
3529 . double_delim($re, $repl) . $flags,
3532 return "s". double_delim($re, $repl) . $flags;
3541 B::Deparse - Perl compiler backend to produce perl code
3545 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3546 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3550 B::Deparse is a backend module for the Perl compiler that generates
3551 perl source code, based on the internal compiled structure that perl
3552 itself creates after parsing a program. The output of B::Deparse won't
3553 be exactly the same as the original source, since perl doesn't keep
3554 track of comments or whitespace, and there isn't a one-to-one
3555 correspondence between perl's syntactical constructions and their
3556 compiled form, but it will often be close. When you use the B<-p>
3557 option, the output also includes parentheses even when they are not
3558 required by precedence, which can make it easy to see if perl is
3559 parsing your expressions the way you intended.
3561 Please note that this module is mainly new and untested code and is
3562 still under development, so it may change in the future.
3566 As with all compiler backend options, these must follow directly after
3567 the '-MO=Deparse', separated by a comma but not any white space.
3573 Add '#line' declarations to the output based on the line and file
3574 locations of the original code.
3578 Print extra parentheses. Without this option, B::Deparse includes
3579 parentheses in its output only when they are needed, based on the
3580 structure of your program. With B<-p>, it uses parentheses (almost)
3581 whenever they would be legal. This can be useful if you are used to
3582 LISP, or if you want to see how perl parses your input. If you say
3584 if ($var & 0x7f == 65) {print "Gimme an A!"}
3585 print ($which ? $a : $b), "\n";
3586 $name = $ENV{USER} or "Bob";
3588 C<B::Deparse,-p> will print
3591 print('Gimme an A!')
3593 (print(($which ? $a : $b)), '???');
3594 (($name = $ENV{'USER'}) or '???')
3596 which probably isn't what you intended (the C<'???'> is a sign that
3597 perl optimized away a constant value).
3601 Expand double-quoted strings into the corresponding combinations of
3602 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3605 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3609 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3610 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3612 Note that the expanded form represents the way perl handles such
3613 constructions internally -- this option actually turns off the reverse
3614 translation that B::Deparse usually does. On the other hand, note that
3615 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3616 of $y into a string before doing the assignment.
3620 Normally, B::Deparse deparses the main code of a program, and all the subs
3621 defined in the same file. To include subs defined in other files, pass the
3622 B<-f> option with the filename. You can pass the B<-f> option several times, to
3623 include more than one secondary file. (Most of the time you don't want to
3624 use it at all.) You can also use this option to include subs which are
3625 defined in the scope of a B<#line> directive with two parameters.
3627 =item B<-s>I<LETTERS>
3629 Tweak the style of B::Deparse's output. The letters should follow
3630 directly after the 's', with no space or punctuation. The following
3631 options are available:
3637 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3654 The default is not to cuddle.
3658 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3662 Use tabs for each 8 columns of indent. The default is to use only spaces.
3663 For instance, if the style options are B<-si4T>, a line that's indented
3664 3 times will be preceded by one tab and four spaces; if the options were
3665 B<-si8T>, the same line would be preceded by three tabs.
3667 =item B<v>I<STRING>B<.>
3669 Print I<STRING> for the value of a constant that can't be determined
3670 because it was optimized away (mnemonic: this happens when a constant
3671 is used in B<v>oid context). The end of the string is marked by a period.
3672 The string should be a valid perl expression, generally a constant.
3673 Note that unless it's a number, it probably needs to be quoted, and on
3674 a command line quotes need to be protected from the shell. Some
3675 conventional values include 0, 1, 42, '', 'foo', and
3676 'Useless use of constant omitted' (which may need to be
3677 B<-sv"'Useless use of constant omitted'.">
3678 or something similar depending on your shell). The default is '???'.
3679 If you're using B::Deparse on a module or other file that's require'd,
3680 you shouldn't use a value that evaluates to false, since the customary
3681 true constant at the end of a module will be in void context when the
3682 file is compiled as a main program.
3688 Expand conventional syntax constructions into equivalent ones that expose
3689 their internal operation. I<LEVEL> should be a digit, with higher values
3690 meaning more expansion. As with B<-q>, this actually involves turning off
3691 special cases in B::Deparse's normal operations.
3693 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3694 while loops with continue blocks; for instance
3696 for ($i = 0; $i < 10; ++$i) {
3709 Note that in a few cases this translation can't be perfectly carried back
3710 into the source code -- if the loop's initializer declares a my variable,
3711 for instance, it won't have the correct scope outside of the loop.
3713 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3714 expressions using C<&&>, C<?:> and C<do {}>; for instance
3716 print 'hi' if $nice;
3728 $nice and print 'hi';
3729 $nice and do { print 'hi' };
3730 $nice ? do { print 'hi' } : do { print 'bye' };
3732 Long sequences of elsifs will turn into nested ternary operators, which
3733 B::Deparse doesn't know how to indent nicely.
3737 =head1 USING B::Deparse AS A MODULE
3742 $deparse = B::Deparse->new("-p", "-sC");
3743 $body = $deparse->coderef2text(\&func);
3744 eval "sub func $body"; # the inverse operation
3748 B::Deparse can also be used on a sub-by-sub basis from other perl
3753 $deparse = B::Deparse->new(OPTIONS)
3755 Create an object to store the state of a deparsing operation and any
3756 options. The options are the same as those that can be given on the
3757 command line (see L</OPTIONS>); options that are separated by commas
3758 after B<-MO=Deparse> should be given as separate strings. Some
3759 options, like B<-u>, don't make sense for a single subroutine, so
3762 =head2 ambient_pragmas
3764 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3766 The compilation of a subroutine can be affected by a few compiler
3767 directives, B<pragmas>. These are:
3781 Assigning to the special variable $[
3801 Ordinarily, if you use B::Deparse on a subroutine which has
3802 been compiled in the presence of one or more of these pragmas,
3803 the output will include statements to turn on the appropriate
3804 directives. So if you then compile the code returned by coderef2text,
3805 it will behave the same way as the subroutine which you deparsed.
3807 However, you may know that you intend to use the results in a
3808 particular context, where some pragmas are already in scope. In
3809 this case, you use the B<ambient_pragmas> method to describe the
3810 assumptions you wish to make.
3812 The parameters it accepts are:
3818 Takes a string, possibly containing several values separated
3819 by whitespace. The special values "all" and "none" mean what you'd
3822 $deparse->ambient_pragmas(strict => 'subs refs');
3826 Takes a number, the value of the array base $[.
3834 If the value is true, then the appropriate pragma is assumed to
3835 be in the ambient scope, otherwise not.
3839 Takes a string, possibly containing a whitespace-separated list of
3840 values. The values "all" and "none" are special. It's also permissible
3841 to pass an array reference here.
3843 $deparser->ambient_pragmas(re => 'eval');
3848 Takes a string, possibly containing a whitespace-separated list of
3849 values. The values "all" and "none" are special, again. It's also
3850 permissible to pass an array reference here.
3852 $deparser->ambient_pragmas(warnings => [qw[void io]]);
3854 If one of the values is the string "FATAL", then all the warnings
3855 in that list will be considered fatal, just as with the B<warnings>
3856 pragma itself. Should you need to specify that some warnings are
3857 fatal, and others are merely enabled, you can pass the B<warnings>
3860 $deparser->ambient_pragmas(
3862 warnings => [FATAL => qw/void io/],
3865 See L<perllexwarn> for more information about lexical warnings.
3871 These two parameters are used to specify the ambient pragmas in
3872 the format used by the special variables $^H and ${^WARNING_BITS}.
3874 They exist principally so that you can write code like:
3876 { my ($hint_bits, $warning_bits);
3877 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
3878 $deparser->ambient_pragmas (
3879 hint_bits => $hint_bits,
3880 warning_bits => $warning_bits,
3884 which specifies that the ambient pragmas are exactly those which
3885 are in scope at the point of calling.
3891 $body = $deparse->coderef2text(\&func)
3892 $body = $deparse->coderef2text(sub ($$) { ... })
3894 Return source code for the body of a subroutine (a block, optionally
3895 preceded by a prototype in parens), given a reference to the
3896 sub. Because a subroutine can have no names, or more than one name,
3897 this method doesn't return a complete subroutine definition -- if you
3898 want to eval the result, you should prepend "sub subname ", or "sub "
3899 for an anonymous function constructor. Unless the sub was defined in
3900 the main:: package, the code will include a package declaration.
3904 See the 'to do' list at the beginning of the module file.
3908 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
3909 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3910 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3911 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.