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 # (See also BUGS section at the end of this file)
99 # - finish tr/// changes
100 # - add option for even more parens (generalize \&foo change)
101 # - left/right context
102 # - treat top-level block specially for incremental output
103 # - copy comments (look at real text with $^P?)
104 # - avoid semis in one-statement blocks
105 # - associativity of &&=, ||=, ?:
106 # - ',' => '=>' (auto-unquote?)
107 # - break long lines ("\r" as discretionary break?)
108 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
109 # - more style options: brace style, hex vs. octal, quotes, ...
110 # - print big ints as hex/octal instead of decimal (heuristic?)
111 # - handle `my $x if 0'?
112 # - coordinate with Data::Dumper (both directions? see previous)
113 # - version using op_next instead of op_first/sibling?
114 # - avoid string copies (pass arrays, one big join?)
117 # Tests that will always fail:
118 # (see t/TEST for the short list)
120 # Object fields (were globals):
123 # (local($a), local($b)) and local($a, $b) have the same internal
124 # representation but the short form looks better. We notice we can
125 # use a large-scale local when checking the list, but need to prevent
126 # individual locals too. This hash holds the addresses of OPs that
127 # have already had their local-ness accounted for. The same thing
131 # CV for current sub (or main program) being deparsed
134 # Cached hash of lexical variables for curcv: keys are names,
135 # each value is an array of pairs, indicating the cop_seq of scopes
136 # in which a var of that name is valid.
139 # COP for statement being deparsed
142 # name of the current package for deparsed code
145 # array of [cop_seq, CV, is_format?] for subs and formats we still
149 # as above, but [name, prototype] for subs that never got a GV
151 # subs_done, forms_done:
152 # keys are addresses of GVs for subs and formats we've already
153 # deparsed (or at least put into subs_todo)
156 # keys are names of subs for which we've printed declarations.
157 # That means we can omit parentheses from the arguments.
162 # cuddle: ` ' or `\n', depending on -sC
167 # A little explanation of how precedence contexts and associativity
170 # deparse() calls each per-op subroutine with an argument $cx (short
171 # for context, but not the same as the cx* in the perl core), which is
172 # a number describing the op's parents in terms of precedence, whether
173 # they're inside an expression or at statement level, etc. (see
174 # chart below). When ops with children call deparse on them, they pass
175 # along their precedence. Fractional values are used to implement
176 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
177 # parentheses hacks. The major disadvantage of this scheme is that
178 # it doesn't know about right sides and left sides, so say if you
179 # assign a listop to a variable, it can't tell it's allowed to leave
180 # the parens off the listop.
183 # 26 [TODO] inside interpolation context ("")
184 # 25 left terms and list operators (leftward)
188 # 21 right ! ~ \ and unary + and -
193 # 16 nonassoc named unary operators
194 # 15 nonassoc < > <= >= lt gt le ge
195 # 14 nonassoc == != <=> eq ne cmp
202 # 7 right = += -= *= etc.
204 # 5 nonassoc list operators (rightward)
208 # 1 statement modifiers
211 # Also, lineseq may pass a fourth parameter to the pp_ routines:
212 # if present, the fourth parameter is passed on by deparse.
214 # If present and true, it means that the op exists directly as
215 # part of a lineseq. Currently it's only used by scopeop to
216 # decide whether its results need to be enclosed in a do {} block.
218 # Nonprinting characters with special meaning:
219 # \cS - steal parens (see maybe_parens_unop)
220 # \n - newline and indent
221 # \t - increase indent
222 # \b - decrease indent (`outdent')
223 # \f - flush left (no indent)
224 # \cK - kill following semicolon, if any
228 return class($op) eq "NULL";
233 my($cv, $is_form) = @_;
234 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
236 if (!null($cv->START) and is_state($cv->START)) {
237 $seq = $cv->START->cop_seq;
241 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
246 my $ent = shift @{$self->{'subs_todo'}};
249 my $name = $self->gv_name($gv);
251 return "format $name =\n"
252 . $self->deparse_format($ent->[1]). "\n";
254 $self->{'subs_declared'}{$name} = 1;
255 if ($name eq "BEGIN") {
256 my $use_dec = $self->begin_is_use($cv);
257 if (defined ($use_dec)) {
258 return () if 0 == length($use_dec);
263 if ($self->{'linenums'}) {
264 my $line = $gv->LINE;
265 my $file = $gv->FILE;
266 $l = "\n\f#line $line \"$file\"\n";
268 return "${l}sub $name " . $self->deparse_sub($cv);
272 # Return a "use" declaration for this BEGIN block, if appropriate
274 my ($self, $cv) = @_;
275 my $root = $cv->ROOT;
276 local @$self{qw'curcv curcvlex'} = ($cv);
278 #B::walkoptree($cv->ROOT, "debug");
279 my $lineseq = $root->first;
280 return if $lineseq->name ne "lineseq";
282 my $req_op = $lineseq->first->sibling;
283 return if $req_op->name ne "require";
286 if ($req_op->first->private & OPpCONST_BARE) {
287 # Actually it should always be a bareword
288 $module = $self->const_sv($req_op->first)->PV;
289 $module =~ s[/][::]g;
293 $module = const($self->const_sv($req_op->first));
297 my $version_op = $req_op->sibling;
298 return if class($version_op) eq "NULL";
299 if ($version_op->name eq "lineseq") {
300 # We have a version parameter; skip nextstate & pushmark
301 my $constop = $version_op->first->next->next;
303 return unless $self->const_sv($constop)->PV eq $module;
304 $constop = $constop->sibling;
305 $version = $self->const_sv($constop)->int_value;
306 $constop = $constop->sibling;
307 return if $constop->name ne "method_named";
308 return if $self->const_sv($constop)->PV ne "VERSION";
311 $lineseq = $version_op->sibling;
312 return if $lineseq->name ne "lineseq";
313 my $entersub = $lineseq->first->sibling;
314 if ($entersub->name eq "stub") {
315 return "use $module $version ();\n" if defined $version;
316 return "use $module ();\n";
318 return if $entersub->name ne "entersub";
320 # See if there are import arguments
323 my $svop = $entersub->first->sibling; # Skip over pushmark
324 return unless $self->const_sv($svop)->PV eq $module;
326 # Pull out the arguments
327 for ($svop=$svop->sibling; $svop->name ne "method_named";
328 $svop = $svop->sibling) {
329 $args .= ", " if length($args);
330 $args .= $self->deparse($svop, 6);
334 my $method_named = $svop;
335 return if $method_named->name ne "method_named";
336 my $method_name = $self->const_sv($method_named)->PV;
338 if ($method_name eq "unimport") {
342 # Certain pragmas are dealt with using hint bits,
343 # so we ignore them here
344 if ($module eq 'strict' || $module eq 'integer'
345 || $module eq 'bytes' || $module eq 'warnings') {
349 if (defined $version && length $args) {
350 return "$use $module $version ($args);\n";
351 } elsif (defined $version) {
352 return "$use $module $version;\n";
353 } elsif (length $args) {
354 return "$use $module ($args);\n";
356 return "$use $module;\n";
361 my ($self, $pack) = @_;
363 if (!defined $pack) {
368 $pack =~ s/(::)?$/::/;
372 my %stash = svref_2object($stash)->ARRAY;
373 while (my ($key, $val) = each %stash) {
374 next if $key eq 'main::'; # avoid infinite recursion
375 my $class = class($val);
376 if ($class eq "PV") {
377 # Just a prototype. As an ugly but fairly effective way
378 # to find out if it belongs here is to see if the AUTOLOAD
379 # (if any) for the stash was defined in one of our files.
380 my $A = $stash{"AUTOLOAD"};
381 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
382 && class($A->CV) eq "CV") {
384 next unless $AF eq $0 || exists $self->{'files'}{$AF};
386 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
387 } elsif ($class eq "IV") {
388 # Just a name. As above.
389 my $A = $stash{"AUTOLOAD"};
390 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
391 && class($A->CV) eq "CV") {
393 next unless $AF eq $0 || exists $self->{'files'}{$AF};
395 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
396 } elsif ($class eq "GV") {
397 if (class(my $cv = $val->CV) ne "SPECIAL") {
398 next if $self->{'subs_done'}{$$val}++;
399 next if $$val != ${$cv->GV}; # Ignore imposters
402 if (class(my $cv = $val->FORM) ne "SPECIAL") {
403 next if $self->{'forms_done'}{$$val}++;
404 next if $$val != ${$cv->GV}; # Ignore imposters
407 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
408 $self->stash_subs($pack . $key);
418 foreach $ar (@{$self->{'protos_todo'}}) {
419 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
420 push @ret, "sub " . $ar->[0] . "$proto;\n";
422 delete $self->{'protos_todo'};
430 while (length($opt = substr($opts, 0, 1))) {
432 $self->{'cuddle'} = " ";
433 $opts = substr($opts, 1);
434 } elsif ($opt eq "i") {
435 $opts =~ s/^i(\d+)//;
436 $self->{'indent_size'} = $1;
437 } elsif ($opt eq "T") {
438 $self->{'use_tabs'} = 1;
439 $opts = substr($opts, 1);
440 } elsif ($opt eq "v") {
441 $opts =~ s/^v([^.]*)(.|$)//;
442 $self->{'ex_const'} = $1;
449 my $self = bless {}, $class;
450 $self->{'subs_todo'} = [];
451 $self->{'files'} = {};
452 $self->{'curstash'} = "main";
453 $self->{'curcop'} = undef;
454 $self->{'cuddle'} = "\n";
455 $self->{'indent_size'} = 4;
456 $self->{'use_tabs'} = 0;
457 $self->{'expand'} = 0;
458 $self->{'unquote'} = 0;
459 $self->{'linenums'} = 0;
460 $self->{'parens'} = 0;
461 $self->{'ex_const'} = "'???'";
463 $self->{'ambient_arybase'} = 0;
464 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
465 $self->{'ambient_hints'} = 0;
468 while (my $arg = shift @_) {
469 if ($arg =~ /^-f(.*)/) {
470 $self->{'files'}{$1} = 1;
471 } elsif ($arg eq "-p") {
472 $self->{'parens'} = 1;
473 } elsif ($arg eq "-l") {
474 $self->{'linenums'} = 1;
475 } elsif ($arg eq "-q") {
476 $self->{'unquote'} = 1;
477 } elsif (substr($arg, 0, 2) eq "-s") {
478 $self->style_opts(substr $arg, 2);
479 } elsif ($arg =~ /^-x(\d)$/) {
480 $self->{'expand'} = $1;
487 # Mask out the bits that C<use vars> uses
488 $warnings::Bits{all} | $warnings::DeadBits{all};
491 # Initialise the contextual information, either from
492 # defaults provided with the ambient_pragmas method,
493 # or from perl's own defaults otherwise.
497 $self->{'arybase'} = $self->{'ambient_arybase'};
498 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
499 ? $self->{'ambient_warnings'} & WARN_MASK
501 $self->{'hints'} = $self->{'ambient_hints'} & 0xFF;
503 # also a convenient place to clear out subs_declared
504 delete $self->{'subs_declared'};
510 my $self = B::Deparse->new(@args);
511 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
512 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
513 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
514 for my $block (@BEGINs, @INITs, @ENDs) {
515 $self->todo($block, 0);
518 $self->{'curcv'} = main_cv;
519 $self->{'curcvlex'} = undef;
520 print $self->print_protos;
521 @{$self->{'subs_todo'}} =
522 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
523 print $self->indent($self->deparse(main_root, 0)), "\n"
524 unless null main_root;
526 while (scalar(@{$self->{'subs_todo'}})) {
527 push @text, $self->next_todo;
529 print $self->indent(join("", @text)), "\n" if @text;
531 # Print __DATA__ section, if necessary
533 if (defined *{$self->{'curstash'}."::DATA"}{IO}) {
535 print readline(*{$self->{'curstash'}."::DATA"});
543 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
546 return $self->indent($self->deparse_sub(svref_2object($sub)));
549 sub ambient_pragmas {
551 my ($arybase, $hint_bits, $warning_bits) = (0, 0);
557 if ($name eq 'strict') {
560 if ($val eq 'none') {
561 $hint_bits &= ~strict::bits(qw/refs subs vars/);
567 @names = qw/refs subs vars/;
573 @names = split' ', $val;
575 $hint_bits |= strict::bits(@names);
578 elsif ($name eq '$[') {
582 elsif ($name eq 'integer'
584 || $name eq 'utf8') {
587 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
590 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
594 elsif ($name eq 're') {
596 if ($val eq 'none') {
597 $hint_bits &= ~re::bits(qw/taint eval asciirange/);
603 @names = qw/taint eval asciirange/;
609 @names = split' ',$val;
611 $hint_bits |= re::bits(@names);
614 elsif ($name eq 'warnings') {
615 if ($val eq 'none') {
616 $warning_bits = "\0"x12;
625 @names = split/\s+/, $val;
628 $warning_bits = "\0"x12 if !defined ($warning_bits);
629 $warning_bits |= warnings::bits(@names);
632 elsif ($name eq 'warning_bits') {
633 $warning_bits = $val;
636 elsif ($name eq 'hint_bits') {
641 croak "Unknown pragma type: $name";
645 croak "The ambient_pragmas method expects an even number of args";
648 $self->{'ambient_arybase'} = $arybase;
649 $self->{'ambient_warnings'} = $warning_bits;
650 $self->{'ambient_hints'} = $hint_bits;
655 my($op, $cx, $flags) = @_;
657 Carp::confess("Null op in deparse") if !defined($op)
658 || class($op) eq "NULL";
659 my $meth = "pp_" . $op->name;
661 return $self->$meth($op, $cx, $flags);
663 return $self->$meth($op, $cx);
669 my @lines = split(/\n/, $txt);
674 my $cmd = substr($line, 0, 1);
675 if ($cmd eq "\t" or $cmd eq "\b") {
676 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
677 if ($self->{'use_tabs'}) {
678 $leader = "\t" x ($level / 8) . " " x ($level % 8);
680 $leader = " " x $level;
682 $line = substr($line, 1);
684 if (substr($line, 0, 1) eq "\f") {
685 $line = substr($line, 1); # no indent
687 $line = $leader . $line;
691 return join("\n", @lines);
698 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
699 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
700 local $self->{'curcop'} = $self->{'curcop'};
701 if ($cv->FLAGS & SVf_POK) {
702 $proto = "(". $cv->PV . ") ";
704 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
706 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
707 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
708 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
711 local($self->{'curcv'}) = $cv;
712 local($self->{'curcvlex'});
713 local(@$self{qw'curstash warnings hints'})
714 = @$self{qw'curstash warnings hints'};
716 if (not null $cv->ROOT) {
717 my $lineseq = $cv->ROOT->first;
718 if ($lineseq->name eq "lineseq") {
720 for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
723 $body = $self->lineseq(undef, @ops).";";
724 my $scope_en = $self->find_scope_en($lineseq);
725 if (defined $scope_en) {
726 my $subs = join"", $self->seq_subs($scope_en);
727 $body .= ";\n$subs" if length($subs);
731 $body = $self->deparse($cv->ROOT->first, 0);
735 my $sv = $cv->const_sv;
737 # uh-oh. inlinable sub... format it differently
738 return $proto . "{ " . const($sv) . " }\n";
739 } else { # XSUB? (or just a declaration)
743 return $proto ."{\n\t$body\n\b}" ."\n";
750 local($self->{'curcv'}) = $form;
751 local($self->{'curcvlex'});
752 local(@$self{qw'curstash warnings hints'})
753 = @$self{'curstash warnings hints'};
754 my $op = $form->ROOT;
756 $op = $op->first->first; # skip leavewrite, lineseq
757 while (not null $op) {
758 $op = $op->sibling; # skip nextstate
760 $kid = $op->first->sibling; # skip pushmark
761 push @text, "\f".$self->const_sv($kid)->PV;
762 $kid = $kid->sibling;
763 for (; not null $kid; $kid = $kid->sibling) {
764 push @exprs, $self->deparse($kid, 0);
766 push @text, "\f".join(", ", @exprs)."\n" if @exprs;
769 return join("", @text) . "\f.";
774 return $op->name eq "leave" || $op->name eq "scope"
775 || $op->name eq "lineseq"
776 || ($op->name eq "null" && class($op) eq "UNOP"
777 && (is_scope($op->first) || $op->first->name eq "enter"));
781 my $name = $_[0]->name;
782 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
785 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
787 return (!null($op) and null($op->sibling)
788 and $op->name eq "null" and class($op) eq "UNOP"
789 and (($op->first->name =~ /^(and|or)$/
790 and $op->first->first->sibling->name eq "lineseq")
791 or ($op->first->name eq "lineseq"
792 and not null $op->first->first->sibling
793 and $op->first->first->sibling->name eq "unstack")
799 return ($op->name eq "rv2sv" or
800 $op->name eq "padsv" or
801 $op->name eq "gv" or # only in array/hash constructs
802 $op->flags & OPf_KIDS && !null($op->first)
803 && $op->first->name eq "gvsv");
808 my($text, $cx, $prec) = @_;
809 if ($prec < $cx # unary ops nest just fine
810 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
811 or $self->{'parens'})
814 # In a unop, let parent reuse our parens; see maybe_parens_unop
815 $text = "\cS" . $text if $cx == 16;
822 # same as above, but get around the `if it looks like a function' rule
823 sub maybe_parens_unop {
825 my($name, $kid, $cx) = @_;
826 if ($cx > 16 or $self->{'parens'}) {
827 $kid = $self->deparse($kid, 1);
828 if ($name eq "umask" && $kid =~ /^\d+$/) {
829 $kid = sprintf("%#o", $kid);
831 return "$name($kid)";
833 $kid = $self->deparse($kid, 16);
834 if ($name eq "umask" && $kid =~ /^\d+$/) {
835 $kid = sprintf("%#o", $kid);
837 if (substr($kid, 0, 1) eq "\cS") {
839 return $name . substr($kid, 1);
840 } elsif (substr($kid, 0, 1) eq "(") {
841 # avoid looks-like-a-function trap with extra parens
842 # (`+' can lead to ambiguities)
843 return "$name(" . $kid . ")";
850 sub maybe_parens_func {
852 my($func, $text, $cx, $prec) = @_;
853 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
854 return "$func($text)";
856 return "$func $text";
862 my($op, $cx, $text) = @_;
863 my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
864 if ($op->private & (OPpLVAL_INTRO|$our_intro)
865 and not $self->{'avoid_local'}{$$op}) {
866 my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
867 if (want_scalar($op)) {
868 return "$our_local $text";
870 return $self->maybe_parens_func("$our_local", $text, $cx, 16);
879 my($op, $cx, $func, @args) = @_;
880 if ($op->private & OPpTARGET_MY) {
881 my $var = $self->padname($op->targ);
882 my $val = $func->($self, $op, 7, @args);
883 return $self->maybe_parens("$var = $val", $cx, 7);
885 return $func->($self, $op, $cx, @args);
892 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
897 my($op, $cx, $text) = @_;
898 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
899 if (want_scalar($op)) {
902 return $self->maybe_parens_func("my", $text, $cx, 16);
909 # The following OPs don't have functions:
911 # pp_padany -- does not exist after parsing
912 # pp_rcatline -- does not exist
914 sub pp_enter { # see also leave
915 cluck "unexpected OP_ENTER";
919 sub pp_pushmark { # see also list
920 cluck "unexpected OP_PUSHMARK";
924 sub pp_leavesub { # see also deparse_sub
925 cluck "unexpected OP_LEAVESUB";
929 sub pp_leavewrite { # see also deparse_format
930 cluck "unexpected OP_LEAVEWRITE";
934 sub pp_method { # see also entersub
935 cluck "unexpected OP_METHOD";
939 sub pp_regcmaybe { # see also regcomp
940 cluck "unexpected OP_REGCMAYBE";
944 sub pp_regcreset { # see also regcomp
945 cluck "unexpected OP_REGCRESET";
949 sub pp_substcont { # see also subst
950 cluck "unexpected OP_SUBSTCONT";
954 sub pp_grepstart { # see also grepwhile
955 cluck "unexpected OP_GREPSTART";
959 sub pp_mapstart { # see also mapwhile
960 cluck "unexpected OP_MAPSTART";
964 sub pp_flip { # see also flop
965 cluck "unexpected OP_FLIP";
969 sub pp_iter { # see also leaveloop
970 cluck "unexpected OP_ITER";
974 sub pp_enteriter { # see also leaveloop
975 cluck "unexpected OP_ENTERITER";
979 sub pp_enterloop { # see also leaveloop
980 cluck "unexpected OP_ENTERLOOP";
984 sub pp_leaveeval { # see also entereval
985 cluck "unexpected OP_LEAVEEVAL";
989 sub pp_entertry { # see also leavetry
990 cluck "unexpected OP_ENTERTRY";
994 # $root should be the op which represents the root of whatever
995 # we're sequencing here. If it's undefined, then we don't append
996 # any subroutine declarations to the deparsed ops, otherwise we
997 # append appropriate declarations.
999 my($self, $root, @ops) = @_;
1002 my $out_cop = $self->{'curcop'};
1003 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1005 if (defined $root) {
1006 $limit_seq = $out_seq;
1007 my $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
1008 $limit_seq = $nseq if !defined($limit_seq)
1009 or defined($nseq) && $nseq < $limit_seq;
1011 $limit_seq = $self->{'limit_seq'}
1012 if defined($self->{'limit_seq'})
1013 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1014 local $self->{'limit_seq'} = $limit_seq;
1015 for (my $i = 0; $i < @ops; $i++) {
1017 if (is_state $ops[$i]) {
1018 $expr = $self->deparse($ops[$i], 0);
1025 if (!is_state $ops[$i] and (my $ls = $ops[$i+1]) and
1026 !null($ops[$i+1]) and $ops[$i+1]->name eq "lineseq")
1028 if ($ls->first && !null($ls->first) && is_state($ls->first)
1029 && (my $sib = $ls->first->sibling)) {
1030 if (!null($sib) && $sib->name eq "leaveloop") {
1031 push @exprs, $expr . $self->for_loop($ops[$i], 0);
1037 $expr .= $self->deparse($ops[$i], 0, (@ops != 1));
1038 $expr =~ s/;\n?\z//;
1041 my $body = join(";\n", grep {length} @exprs);
1043 if (defined $root && defined $limit_seq) {
1044 $subs = join "\n", $self->seq_subs($limit_seq);
1046 return join(";\n", grep {length} $body, $subs);
1050 my($real_block, $self, $op, $cx, $flags) = @_;
1054 local(@$self{qw'curstash warnings hints'})
1055 = @$self{qw'curstash warnings hints'} if $real_block;
1057 $kid = $op->first->sibling; # skip enter
1058 if (is_miniwhile($kid)) {
1059 my $top = $kid->first;
1060 my $name = $top->name;
1061 if ($name eq "and") {
1063 } elsif ($name eq "or") {
1065 } else { # no conditional -> while 1 or until 0
1066 return $self->deparse($top->first, 1) . " while 1";
1068 my $cond = $top->first;
1069 my $body = $cond->sibling->first; # skip lineseq
1070 $cond = $self->deparse($cond, 1);
1071 $body = $self->deparse($body, 1);
1072 return "$body $name $cond";
1077 for (; !null($kid); $kid = $kid->sibling) {
1080 if ($flags || $cx > 0) { # inside an expression, (a do {} while for lineseq)
1081 return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
1083 my $lineseq = $self->lineseq($op, @kids);
1084 return (length ($lineseq) ? "$lineseq;" : "");
1088 sub pp_scope { scopeop(0, @_); }
1089 sub pp_lineseq { scopeop(0, @_); }
1090 sub pp_leave { scopeop(1, @_); }
1092 # The BEGIN {} is used here because otherwise this code isn't executed
1093 # when you run B::Deparse on itself.
1095 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1096 "ENV", "ARGV", "ARGVOUT", "_"); }
1101 Carp::confess() if $gv->isa("B::CV");
1102 my $stash = $gv->STASH->NAME;
1103 my $name = $gv->SAFENAME;
1104 if ($stash eq $self->{'curstash'} or $globalnames{$name}
1105 or $name =~ /^[^A-Za-z_]/)
1109 $stash = $stash . "::";
1111 if ($name =~ /^\^../) {
1112 $name = "{$name}"; # ${^WARNING_BITS} etc
1114 return $stash . $name;
1117 # Return the name to use for a stash variable.
1118 # If a lexical with the same name is in scope, it may need to be
1120 sub stash_variable {
1121 my ($self, $prefix, $name) = @_;
1123 return "$prefix$name" if $name =~ /::/;
1125 unless ($prefix eq '$' || $prefix eq '@' ||
1126 $prefix eq '%' || $prefix eq '$#') {
1127 return "$prefix$name";
1130 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1131 return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
1132 return "$prefix$name";
1136 my ($self, $name) = @_;
1137 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1139 return 0 if !defined($self->{'curcop'});
1140 my $seq = $self->{'curcop'}->cop_seq;
1141 return 0 if !exists $self->{'curcvlex'}{$name};
1142 for my $a (@{$self->{'curcvlex'}{$name}}) {
1143 my ($st, $en) = @$a;
1144 return 1 if $seq > $st && $seq <= $en;
1149 sub populate_curcvlex {
1151 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1152 my @padlist = $cv->PADLIST->ARRAY;
1153 my @ns = $padlist[0]->ARRAY;
1155 for (my $i=0; $i<@ns; ++$i) {
1156 next if class($ns[$i]) eq "SPECIAL";
1157 next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars
1158 if (class($ns[$i]) eq "PV") {
1159 # Probably that pesky lexical @_
1162 my $name = $ns[$i]->PVX;
1163 my $seq_st = $ns[$i]->NVX;
1164 my $seq_en = int($ns[$i]->IVX);
1166 push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
1171 sub find_scope_st { ((find_scope(@_))[0]); }
1172 sub find_scope_en { ((find_scope(@_))[1]); }
1174 # Recurses down the tree, looking for pad variable introductions and COPs
1176 my ($self, $op, $scope_st, $scope_en) = @_;
1177 Carp::cluck() if !defined $op;
1178 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1180 for (my $o=$op->first; $$o; $o=$o->sibling) {
1181 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1182 my $s = int($self->padname_sv($o->targ)->NVX);
1183 my $e = $self->padname_sv($o->targ)->IVX;
1184 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1185 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1187 elsif (is_state($o)) {
1188 my $c = $o->cop_seq;
1189 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1190 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1192 elsif ($o->flags & OPf_KIDS) {
1193 ($scope_st, $scope_en) =
1194 $self->find_scope($o, $scope_st, $scope_en)
1198 return ($scope_st, $scope_en);
1201 # Returns a list of subs which should be inserted before the COP
1203 my ($self, $op, $out_seq) = @_;
1204 my $seq = $op->cop_seq;
1205 # If we have nephews, then our sequence number indicates
1206 # the cop_seq of the end of some sort of scope.
1207 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1208 and my $nseq = $self->find_scope_st($op->sibling) ) {
1211 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1212 return $self->seq_subs($seq);
1216 my ($self, $seq) = @_;
1218 #push @text, "# ($seq)\n";
1220 return "" if !defined $seq;
1221 while (scalar(@{$self->{'subs_todo'}})
1222 and $seq > $self->{'subs_todo'}[0][0]) {
1223 push @text, $self->next_todo;
1228 # Notice how subs and formats are inserted between statements here;
1229 # also $[ assignments and pragmas.
1233 $self->{'curcop'} = $op;
1235 push @text, $self->cop_subs($op);
1236 push @text, $op->label . ": " if $op->label;
1237 my $stash = $op->stashpv;
1238 if ($stash ne $self->{'curstash'}) {
1239 push @text, "package $stash;\n";
1240 $self->{'curstash'} = $stash;
1242 if ($self->{'linenums'}) {
1243 push @text, "\f#line " . $op->line .
1244 ' "' . $op->file, qq'"\n';
1247 if ($self->{'arybase'} != $op->arybase) {
1248 push @text, '$[ = '. $op->arybase .";\n";
1249 $self->{'arybase'} = $op->arybase;
1252 my $warnings = $op->warnings;
1254 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1255 $warning_bits = $warnings::Bits{"all"};
1257 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1258 $warning_bits = "\0"x12;
1260 elsif ($warnings->isa("B::SPECIAL")) {
1261 $warning_bits = undef;
1264 $warning_bits = $warnings->PV & WARN_MASK;
1267 if (defined ($warning_bits) and
1268 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1269 push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1270 $self->{'warnings'} = $warning_bits;
1273 if ($self->{'hints'} != $op->private) {
1274 push @text, declare_hints($self->{'hints'}, $op->private);
1275 $self->{'hints'} = $op->private;
1278 return join("", @text);
1281 sub declare_warnings {
1282 my ($from, $to) = @_;
1283 if (($to & WARN_MASK) eq warnings::bits("all")) {
1284 return "use warnings;\n";
1286 elsif (($to & WARN_MASK) eq "\0"x length($to)) {
1287 return "no warnings;\n";
1289 return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n";
1293 my ($from, $to) = @_;
1294 my $use = $to & ~$from;
1295 my $no = $from & ~$to;
1297 for my $pragma (hint_pragmas($use)) {
1298 $decls .= "use $pragma;\n";
1300 for my $pragma (hint_pragmas($no)) {
1301 $decls .= "no $pragma;\n";
1309 push @pragmas, "integer" if $bits & 0x1;
1310 push @pragmas, "strict 'refs'" if $bits & 0x2;
1311 push @pragmas, "bytes" if $bits & 0x8;
1315 sub pp_dbstate { pp_nextstate(@_) }
1316 sub pp_setstate { pp_nextstate(@_) }
1318 sub pp_unstack { return "" } # see also leaveloop
1322 my($op, $cx, $name) = @_;
1328 my($op, $cx, $name) = @_;
1336 sub pp_wantarray { baseop(@_, "wantarray") }
1337 sub pp_fork { baseop(@_, "fork") }
1338 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1339 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1340 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1341 sub pp_tms { baseop(@_, "times") }
1342 sub pp_ghostent { baseop(@_, "gethostent") }
1343 sub pp_gnetent { baseop(@_, "getnetent") }
1344 sub pp_gprotoent { baseop(@_, "getprotoent") }
1345 sub pp_gservent { baseop(@_, "getservent") }
1346 sub pp_ehostent { baseop(@_, "endhostent") }
1347 sub pp_enetent { baseop(@_, "endnetent") }
1348 sub pp_eprotoent { baseop(@_, "endprotoent") }
1349 sub pp_eservent { baseop(@_, "endservent") }
1350 sub pp_gpwent { baseop(@_, "getpwent") }
1351 sub pp_spwent { baseop(@_, "setpwent") }
1352 sub pp_epwent { baseop(@_, "endpwent") }
1353 sub pp_ggrent { baseop(@_, "getgrent") }
1354 sub pp_sgrent { baseop(@_, "setgrent") }
1355 sub pp_egrent { baseop(@_, "endgrent") }
1356 sub pp_getlogin { baseop(@_, "getlogin") }
1358 sub POSTFIX () { 1 }
1360 # I couldn't think of a good short name, but this is the category of
1361 # symbolic unary operators with interesting precedence
1365 my($op, $cx, $name, $prec, $flags) = (@_, 0);
1366 my $kid = $op->first;
1367 $kid = $self->deparse($kid, $prec);
1368 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1372 sub pp_preinc { pfixop(@_, "++", 23) }
1373 sub pp_predec { pfixop(@_, "--", 23) }
1374 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1375 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1376 sub pp_i_preinc { pfixop(@_, "++", 23) }
1377 sub pp_i_predec { pfixop(@_, "--", 23) }
1378 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1379 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1380 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1382 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1386 if ($op->first->name =~ /^(i_)?negate$/) {
1388 $self->pfixop($op, $cx, "-", 21.5);
1390 $self->pfixop($op, $cx, "-", 21);
1393 sub pp_i_negate { pp_negate(@_) }
1399 $self->pfixop($op, $cx, "not ", 4);
1401 $self->pfixop($op, $cx, "!", 21);
1407 my($op, $cx, $name) = @_;
1409 if ($op->flags & OPf_KIDS) {
1411 if (defined prototype("CORE::$name")
1412 && prototype("CORE::$name") =~ /^;?\*/
1413 && $kid->name eq "rv2gv") {
1417 return $self->maybe_parens_unop($name, $kid, $cx);
1419 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1423 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1424 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1425 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1426 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1427 sub pp_defined { unop(@_, "defined") }
1428 sub pp_undef { unop(@_, "undef") }
1429 sub pp_study { unop(@_, "study") }
1430 sub pp_ref { unop(@_, "ref") }
1431 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1433 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1434 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1435 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1436 sub pp_srand { unop(@_, "srand") }
1437 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1438 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1439 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1440 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1441 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1442 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1443 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1445 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1446 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1447 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1449 sub pp_each { unop(@_, "each") }
1450 sub pp_values { unop(@_, "values") }
1451 sub pp_keys { unop(@_, "keys") }
1452 sub pp_pop { unop(@_, "pop") }
1453 sub pp_shift { unop(@_, "shift") }
1455 sub pp_caller { unop(@_, "caller") }
1456 sub pp_reset { unop(@_, "reset") }
1457 sub pp_exit { unop(@_, "exit") }
1458 sub pp_prototype { unop(@_, "prototype") }
1460 sub pp_close { unop(@_, "close") }
1461 sub pp_fileno { unop(@_, "fileno") }
1462 sub pp_umask { unop(@_, "umask") }
1463 sub pp_untie { unop(@_, "untie") }
1464 sub pp_tied { unop(@_, "tied") }
1465 sub pp_dbmclose { unop(@_, "dbmclose") }
1466 sub pp_getc { unop(@_, "getc") }
1467 sub pp_eof { unop(@_, "eof") }
1468 sub pp_tell { unop(@_, "tell") }
1469 sub pp_getsockname { unop(@_, "getsockname") }
1470 sub pp_getpeername { unop(@_, "getpeername") }
1472 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1473 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1474 sub pp_readlink { unop(@_, "readlink") }
1475 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1476 sub pp_readdir { unop(@_, "readdir") }
1477 sub pp_telldir { unop(@_, "telldir") }
1478 sub pp_rewinddir { unop(@_, "rewinddir") }
1479 sub pp_closedir { unop(@_, "closedir") }
1480 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1481 sub pp_localtime { unop(@_, "localtime") }
1482 sub pp_gmtime { unop(@_, "gmtime") }
1483 sub pp_alarm { unop(@_, "alarm") }
1484 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1486 sub pp_dofile { unop(@_, "do") }
1487 sub pp_entereval { unop(@_, "eval") }
1489 sub pp_ghbyname { unop(@_, "gethostbyname") }
1490 sub pp_gnbyname { unop(@_, "getnetbyname") }
1491 sub pp_gpbyname { unop(@_, "getprotobyname") }
1492 sub pp_shostent { unop(@_, "sethostent") }
1493 sub pp_snetent { unop(@_, "setnetent") }
1494 sub pp_sprotoent { unop(@_, "setprotoent") }
1495 sub pp_sservent { unop(@_, "setservent") }
1496 sub pp_gpwnam { unop(@_, "getpwnam") }
1497 sub pp_gpwuid { unop(@_, "getpwuid") }
1498 sub pp_ggrnam { unop(@_, "getgrnam") }
1499 sub pp_ggrgid { unop(@_, "getgrgid") }
1501 sub pp_lock { unop(@_, "lock") }
1507 if ($op->private & OPpEXISTS_SUB) {
1508 # Checking for the existence of a subroutine
1509 return $self->maybe_parens_func("exists",
1510 $self->pp_rv2cv($op->first, 16), $cx, 16);
1512 if ($op->flags & OPf_SPECIAL) {
1513 # Array element, not hash element
1514 return $self->maybe_parens_func("exists",
1515 $self->pp_aelem($op->first, 16), $cx, 16);
1517 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1525 if ($op->private & OPpSLICE) {
1526 if ($op->flags & OPf_SPECIAL) {
1527 # Deleting from an array, not a hash
1528 return $self->maybe_parens_func("delete",
1529 $self->pp_aslice($op->first, 16),
1532 return $self->maybe_parens_func("delete",
1533 $self->pp_hslice($op->first, 16),
1536 if ($op->flags & OPf_SPECIAL) {
1537 # Deleting from an array, not a hash
1538 return $self->maybe_parens_func("delete",
1539 $self->pp_aelem($op->first, 16),
1542 return $self->maybe_parens_func("delete",
1543 $self->pp_helem($op->first, 16),
1551 if (class($op) eq "UNOP" and $op->first->name eq "const"
1552 and $op->first->private & OPpCONST_BARE)
1554 my $name = $self->const_sv($op->first)->PV;
1557 return "require $name";
1559 $self->unop($op, $cx, "require");
1566 my $kid = $op->first;
1567 if (not null $kid->sibling) {
1568 # XXX Was a here-doc
1569 return $self->dquote($op);
1571 $self->unop(@_, "scalar");
1578 #cluck "curcv was undef" unless $self->{curcv};
1579 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1585 my $kid = $op->first;
1586 if ($kid->name eq "null") {
1588 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1589 my($pre, $post) = @{{"anonlist" => ["[","]"],
1590 "anonhash" => ["{","}"]}->{$kid->name}};
1592 $kid = $kid->first->sibling; # skip pushmark
1593 for (; !null($kid); $kid = $kid->sibling) {
1594 $expr = $self->deparse($kid, 6);
1597 return $pre . join(", ", @exprs) . $post;
1598 } elsif (!null($kid->sibling) and
1599 $kid->sibling->name eq "anoncode") {
1601 $self->deparse_sub($self->padval($kid->sibling->targ));
1602 } elsif ($kid->name eq "pushmark") {
1603 my $sib_name = $kid->sibling->name;
1604 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1605 and not $kid->sibling->flags & OPf_REF)
1607 # The @a in \(@a) isn't in ref context, but only when the
1609 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1610 } elsif ($sib_name eq 'entersub') {
1611 my $text = $self->deparse($kid->sibling, 1);
1612 # Always show parens for \(&func()), but only with -p otherwise
1613 $text = "($text)" if $self->{'parens'}
1614 or $kid->sibling->private & OPpENTERSUB_AMPER;
1619 $self->pfixop($op, $cx, "\\", 20);
1622 sub pp_srefgen { pp_refgen(@_) }
1627 my $kid = $op->first;
1628 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1629 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
1630 return $self->unop($op, $cx, "readline");
1633 # Unary operators that can occur as pseudo-listops inside double quotes
1636 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1638 if ($op->flags & OPf_KIDS) {
1640 # If there's more than one kid, the first is an ex-pushmark.
1641 $kid = $kid->sibling if not null $kid->sibling;
1642 return $self->maybe_parens_unop($name, $kid, $cx);
1644 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1648 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1649 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1650 sub pp_uc { dq_unop(@_, "uc") }
1651 sub pp_lc { dq_unop(@_, "lc") }
1652 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1656 my ($op, $cx, $name) = @_;
1657 if (class($op) eq "PVOP") {
1658 return "$name " . $op->pv;
1659 } elsif (class($op) eq "OP") {
1661 } elsif (class($op) eq "UNOP") {
1662 # Note -- loop exits are actually exempt from the
1663 # looks-like-a-func rule, but a few extra parens won't hurt
1664 return $self->maybe_parens_unop($name, $op->first, $cx);
1668 sub pp_last { loopex(@_, "last") }
1669 sub pp_next { loopex(@_, "next") }
1670 sub pp_redo { loopex(@_, "redo") }
1671 sub pp_goto { loopex(@_, "goto") }
1672 sub pp_dump { loopex(@_, "dump") }
1676 my($op, $cx, $name) = @_;
1677 if (class($op) eq "UNOP") {
1678 # Genuine `-X' filetests are exempt from the LLAFR, but not
1679 # l?stat(); for the sake of clarity, give'em all parens
1680 return $self->maybe_parens_unop($name, $op->first, $cx);
1681 } elsif (class($op) eq "SVOP") {
1682 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1683 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1688 sub pp_lstat { ftst(@_, "lstat") }
1689 sub pp_stat { ftst(@_, "stat") }
1690 sub pp_ftrread { ftst(@_, "-R") }
1691 sub pp_ftrwrite { ftst(@_, "-W") }
1692 sub pp_ftrexec { ftst(@_, "-X") }
1693 sub pp_fteread { ftst(@_, "-r") }
1694 sub pp_ftewrite { ftst(@_, "-w") }
1695 sub pp_fteexec { ftst(@_, "-x") }
1696 sub pp_ftis { ftst(@_, "-e") }
1697 sub pp_fteowned { ftst(@_, "-O") }
1698 sub pp_ftrowned { ftst(@_, "-o") }
1699 sub pp_ftzero { ftst(@_, "-z") }
1700 sub pp_ftsize { ftst(@_, "-s") }
1701 sub pp_ftmtime { ftst(@_, "-M") }
1702 sub pp_ftatime { ftst(@_, "-A") }
1703 sub pp_ftctime { ftst(@_, "-C") }
1704 sub pp_ftsock { ftst(@_, "-S") }
1705 sub pp_ftchr { ftst(@_, "-c") }
1706 sub pp_ftblk { ftst(@_, "-b") }
1707 sub pp_ftfile { ftst(@_, "-f") }
1708 sub pp_ftdir { ftst(@_, "-d") }
1709 sub pp_ftpipe { ftst(@_, "-p") }
1710 sub pp_ftlink { ftst(@_, "-l") }
1711 sub pp_ftsuid { ftst(@_, "-u") }
1712 sub pp_ftsgid { ftst(@_, "-g") }
1713 sub pp_ftsvtx { ftst(@_, "-k") }
1714 sub pp_fttty { ftst(@_, "-t") }
1715 sub pp_fttext { ftst(@_, "-T") }
1716 sub pp_ftbinary { ftst(@_, "-B") }
1718 sub SWAP_CHILDREN () { 1 }
1719 sub ASSIGN () { 2 } # has OP= variant
1720 sub LIST_CONTEXT () { 4 } # Assignment is in list context
1726 my $name = $op->name;
1727 if ($name eq "concat" and $op->first->name eq "concat") {
1728 # avoid spurious `=' -- see comment in pp_concat
1731 if ($name eq "null" and class($op) eq "UNOP"
1732 and $op->first->name =~ /^(and|x?or)$/
1733 and null $op->first->sibling)
1735 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1736 # with a null that's used as the common end point of the two
1737 # flows of control. For precedence purposes, ignore it.
1738 # (COND_EXPRs have these too, but we don't bother with
1739 # their associativity).
1740 return assoc_class($op->first);
1742 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1745 # Left associative operators, like `+', for which
1746 # $a + $b + $c is equivalent to ($a + $b) + $c
1749 %left = ('multiply' => 19, 'i_multiply' => 19,
1750 'divide' => 19, 'i_divide' => 19,
1751 'modulo' => 19, 'i_modulo' => 19,
1753 'add' => 18, 'i_add' => 18,
1754 'subtract' => 18, 'i_subtract' => 18,
1756 'left_shift' => 17, 'right_shift' => 17,
1758 'bit_or' => 12, 'bit_xor' => 12,
1760 'or' => 2, 'xor' => 2,
1764 sub deparse_binop_left {
1766 my($op, $left, $prec) = @_;
1767 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1768 and $left{assoc_class($op)} == $left{assoc_class($left)})
1770 return $self->deparse($left, $prec - .00001);
1772 return $self->deparse($left, $prec);
1776 # Right associative operators, like `=', for which
1777 # $a = $b = $c is equivalent to $a = ($b = $c)
1780 %right = ('pow' => 22,
1781 'sassign=' => 7, 'aassign=' => 7,
1782 'multiply=' => 7, 'i_multiply=' => 7,
1783 'divide=' => 7, 'i_divide=' => 7,
1784 'modulo=' => 7, 'i_modulo=' => 7,
1786 'add=' => 7, 'i_add=' => 7,
1787 'subtract=' => 7, 'i_subtract=' => 7,
1789 'left_shift=' => 7, 'right_shift=' => 7,
1791 'bit_or=' => 7, 'bit_xor=' => 7,
1797 sub deparse_binop_right {
1799 my($op, $right, $prec) = @_;
1800 if ($right{assoc_class($op)} && $right{assoc_class($right)}
1801 and $right{assoc_class($op)} == $right{assoc_class($right)})
1803 return $self->deparse($right, $prec - .00001);
1805 return $self->deparse($right, $prec);
1811 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1812 my $left = $op->first;
1813 my $right = $op->last;
1815 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1819 if ($flags & SWAP_CHILDREN) {
1820 ($left, $right) = ($right, $left);
1822 $left = $self->deparse_binop_left($op, $left, $prec);
1823 $left = "($left)" if $flags & LIST_CONTEXT && $left =~ /^\$/;
1824 $right = $self->deparse_binop_right($op, $right, $prec);
1825 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1828 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1829 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1830 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1831 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1832 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1833 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1834 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1835 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1836 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1837 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1838 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1840 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1841 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1842 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1843 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1844 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1846 sub pp_eq { binop(@_, "==", 14) }
1847 sub pp_ne { binop(@_, "!=", 14) }
1848 sub pp_lt { binop(@_, "<", 15) }
1849 sub pp_gt { binop(@_, ">", 15) }
1850 sub pp_ge { binop(@_, ">=", 15) }
1851 sub pp_le { binop(@_, "<=", 15) }
1852 sub pp_ncmp { binop(@_, "<=>", 14) }
1853 sub pp_i_eq { binop(@_, "==", 14) }
1854 sub pp_i_ne { binop(@_, "!=", 14) }
1855 sub pp_i_lt { binop(@_, "<", 15) }
1856 sub pp_i_gt { binop(@_, ">", 15) }
1857 sub pp_i_ge { binop(@_, ">=", 15) }
1858 sub pp_i_le { binop(@_, "<=", 15) }
1859 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1861 sub pp_seq { binop(@_, "eq", 14) }
1862 sub pp_sne { binop(@_, "ne", 14) }
1863 sub pp_slt { binop(@_, "lt", 15) }
1864 sub pp_sgt { binop(@_, "gt", 15) }
1865 sub pp_sge { binop(@_, "ge", 15) }
1866 sub pp_sle { binop(@_, "le", 15) }
1867 sub pp_scmp { binop(@_, "cmp", 14) }
1869 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1870 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
1872 # `.' is special because concats-of-concats are optimized to save copying
1873 # by making all but the first concat stacked. The effect is as if the
1874 # programmer had written `($a . $b) .= $c', except legal.
1875 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1879 my $left = $op->first;
1880 my $right = $op->last;
1883 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1887 $left = $self->deparse_binop_left($op, $left, $prec);
1888 $right = $self->deparse_binop_right($op, $right, $prec);
1889 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1892 # `x' is weird when the left arg is a list
1896 my $left = $op->first;
1897 my $right = $op->last;
1900 if ($op->flags & OPf_STACKED) {
1904 if (null($right)) { # list repeat; count is inside left-side ex-list
1905 my $kid = $left->first->sibling; # skip pushmark
1907 for (; !null($kid->sibling); $kid = $kid->sibling) {
1908 push @exprs, $self->deparse($kid, 6);
1911 $left = "(" . join(", ", @exprs). ")";
1913 $left = $self->deparse_binop_left($op, $left, $prec);
1915 $right = $self->deparse_binop_right($op, $right, $prec);
1916 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1921 my ($op, $cx, $type) = @_;
1922 my $left = $op->first;
1923 my $right = $left->sibling;
1924 $left = $self->deparse($left, 9);
1925 $right = $self->deparse($right, 9);
1926 return $self->maybe_parens("$left $type $right", $cx, 9);
1932 my $flip = $op->first;
1933 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1934 return $self->range($flip->first, $cx, $type);
1937 # one-line while/until is handled in pp_leave
1941 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1942 my $left = $op->first;
1943 my $right = $op->first->sibling;
1944 if ($cx == 0 and is_scope($right) and $blockname
1945 and $self->{'expand'} < 7)
1947 $left = $self->deparse($left, 1);
1948 $right = $self->deparse($right, 0);
1949 return "$blockname ($left) {\n\t$right\n\b}\cK";
1950 } elsif ($cx == 0 and $blockname and not $self->{'parens'}
1951 and $self->{'expand'} < 7) { # $b if $a
1952 $right = $self->deparse($right, 1);
1953 $left = $self->deparse($left, 1);
1954 return "$right $blockname $left";
1955 } elsif ($cx > $lowprec and $highop) { # $a && $b
1956 $left = $self->deparse_binop_left($op, $left, $highprec);
1957 $right = $self->deparse_binop_right($op, $right, $highprec);
1958 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1959 } else { # $a and $b
1960 $left = $self->deparse_binop_left($op, $left, $lowprec);
1961 $right = $self->deparse_binop_right($op, $right, $lowprec);
1962 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1966 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1967 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1969 # xor is syntactically a logop, but it's really a binop (contrary to
1970 # old versions of opcode.pl). Syntax is what matters here.
1971 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1975 my ($op, $cx, $opname) = @_;
1976 my $left = $op->first;
1977 my $right = $op->first->sibling->first; # skip sassign
1978 $left = $self->deparse($left, 7);
1979 $right = $self->deparse($right, 7);
1980 return $self->maybe_parens("$left $opname $right", $cx, 7);
1983 sub pp_andassign { logassignop(@_, "&&=") }
1984 sub pp_orassign { logassignop(@_, "||=") }
1988 my($op, $cx, $name) = @_;
1990 my $parens = ($cx >= 5) || $self->{'parens'};
1991 my $kid = $op->first->sibling;
1992 return $name if null $kid;
1994 if (defined prototype("CORE::$name")
1995 && prototype("CORE::$name") =~ /^;?\*/
1996 && $kid->name eq "rv2gv") {
1997 $first = $self->deparse($kid->first, 6);
2000 $first = $self->deparse($kid, 6);
2002 if ($name eq "chmod" && $first =~ /^\d+$/) {
2003 $first = sprintf("%#o", $first);
2005 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
2006 push @exprs, $first;
2007 $kid = $kid->sibling;
2008 for (; !null($kid); $kid = $kid->sibling) {
2009 push @exprs, $self->deparse($kid, 6);
2012 return "$name(" . join(", ", @exprs) . ")";
2014 return "$name " . join(", ", @exprs);
2018 sub pp_bless { listop(@_, "bless") }
2019 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
2020 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
2021 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
2022 sub pp_index { maybe_targmy(@_, \&listop, "index") }
2023 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
2024 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
2025 sub pp_formline { listop(@_, "formline") } # see also deparse_format
2026 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
2027 sub pp_unpack { listop(@_, "unpack") }
2028 sub pp_pack { listop(@_, "pack") }
2029 sub pp_join { maybe_targmy(@_, \&listop, "join") }
2030 sub pp_splice { listop(@_, "splice") }
2031 sub pp_push { maybe_targmy(@_, \&listop, "push") }
2032 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
2033 sub pp_reverse { listop(@_, "reverse") }
2034 sub pp_warn { listop(@_, "warn") }
2035 sub pp_die { listop(@_, "die") }
2036 # Actually, return is exempt from the LLAFR (see examples in this very
2037 # module!), but for consistency's sake, ignore that fact
2038 sub pp_return { listop(@_, "return") }
2039 sub pp_open { listop(@_, "open") }
2040 sub pp_pipe_op { listop(@_, "pipe") }
2041 sub pp_tie { listop(@_, "tie") }
2042 sub pp_binmode { listop(@_, "binmode") }
2043 sub pp_dbmopen { listop(@_, "dbmopen") }
2044 sub pp_sselect { listop(@_, "select") }
2045 sub pp_select { listop(@_, "select") }
2046 sub pp_read { listop(@_, "read") }
2047 sub pp_sysopen { listop(@_, "sysopen") }
2048 sub pp_sysseek { listop(@_, "sysseek") }
2049 sub pp_sysread { listop(@_, "sysread") }
2050 sub pp_syswrite { listop(@_, "syswrite") }
2051 sub pp_send { listop(@_, "send") }
2052 sub pp_recv { listop(@_, "recv") }
2053 sub pp_seek { listop(@_, "seek") }
2054 sub pp_fcntl { listop(@_, "fcntl") }
2055 sub pp_ioctl { listop(@_, "ioctl") }
2056 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
2057 sub pp_socket { listop(@_, "socket") }
2058 sub pp_sockpair { listop(@_, "sockpair") }
2059 sub pp_bind { listop(@_, "bind") }
2060 sub pp_connect { listop(@_, "connect") }
2061 sub pp_listen { listop(@_, "listen") }
2062 sub pp_accept { listop(@_, "accept") }
2063 sub pp_shutdown { listop(@_, "shutdown") }
2064 sub pp_gsockopt { listop(@_, "getsockopt") }
2065 sub pp_ssockopt { listop(@_, "setsockopt") }
2066 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
2067 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
2068 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
2069 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
2070 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
2071 sub pp_link { maybe_targmy(@_, \&listop, "link") }
2072 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
2073 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
2074 sub pp_open_dir { listop(@_, "opendir") }
2075 sub pp_seekdir { listop(@_, "seekdir") }
2076 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
2077 sub pp_system { maybe_targmy(@_, \&listop, "system") }
2078 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
2079 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
2080 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
2081 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
2082 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
2083 sub pp_shmget { listop(@_, "shmget") }
2084 sub pp_shmctl { listop(@_, "shmctl") }
2085 sub pp_shmread { listop(@_, "shmread") }
2086 sub pp_shmwrite { listop(@_, "shmwrite") }
2087 sub pp_msgget { listop(@_, "msgget") }
2088 sub pp_msgctl { listop(@_, "msgctl") }
2089 sub pp_msgsnd { listop(@_, "msgsnd") }
2090 sub pp_msgrcv { listop(@_, "msgrcv") }
2091 sub pp_semget { listop(@_, "semget") }
2092 sub pp_semctl { listop(@_, "semctl") }
2093 sub pp_semop { listop(@_, "semop") }
2094 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
2095 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
2096 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
2097 sub pp_gsbyname { listop(@_, "getservbyname") }
2098 sub pp_gsbyport { listop(@_, "getservbyport") }
2099 sub pp_syscall { listop(@_, "syscall") }
2104 my $text = $self->dq($op->first->sibling); # skip pushmark
2105 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
2106 or $text =~ /[<>]/) {
2107 return 'glob(' . single_delim('qq', '"', $text) . ')';
2109 return '<' . $text . '>';
2113 # Truncate is special because OPf_SPECIAL makes a bareword first arg
2114 # be a filehandle. This could probably be better fixed in the core
2115 # by moving the GV lookup into ck_truc.
2121 my $parens = ($cx >= 5) || $self->{'parens'};
2122 my $kid = $op->first->sibling;
2124 if ($op->flags & OPf_SPECIAL) {
2125 # $kid is an OP_CONST
2126 $fh = $self->const_sv($kid)->PV;
2128 $fh = $self->deparse($kid, 6);
2129 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
2131 my $len = $self->deparse($kid->sibling, 6);
2133 return "truncate($fh, $len)";
2135 return "truncate $fh, $len";
2141 my($op, $cx, $name) = @_;
2143 my $kid = $op->first->sibling;
2145 if ($op->flags & OPf_STACKED) {
2147 $indir = $indir->first; # skip rv2gv
2148 if (is_scope($indir)) {
2149 $indir = "{" . $self->deparse($indir, 0) . "}";
2150 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
2151 $indir = $self->const_sv($indir)->PV;
2153 $indir = $self->deparse($indir, 24);
2155 $indir = $indir . " ";
2156 $kid = $kid->sibling;
2158 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
2159 $indir = ($op->private & OPpSORT_REVERSE) ? '{$b <=> $a} '
2162 elsif ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
2163 $indir = '{$b cmp $a} ';
2165 for (; !null($kid); $kid = $kid->sibling) {
2166 $expr = $self->deparse($kid, 6);
2169 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
2173 sub pp_prtf { indirop(@_, "printf") }
2174 sub pp_print { indirop(@_, "print") }
2175 sub pp_sort { indirop(@_, "sort") }
2179 my($op, $cx, $name) = @_;
2181 my $kid = $op->first; # this is the (map|grep)start
2182 $kid = $kid->first->sibling; # skip a pushmark
2183 my $code = $kid->first; # skip a null
2184 if (is_scope $code) {
2185 $code = "{" . $self->deparse($code, 0) . "} ";
2187 $code = $self->deparse($code, 24) . ", ";
2189 $kid = $kid->sibling;
2190 for (; !null($kid); $kid = $kid->sibling) {
2191 $expr = $self->deparse($kid, 6);
2192 push @exprs, $expr if $expr;
2194 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2197 sub pp_mapwhile { mapop(@_, "map") }
2198 sub pp_grepwhile { mapop(@_, "grep") }
2204 my $kid = $op->first->sibling; # skip pushmark
2206 my $local = "either"; # could be local(...), my(...) or our(...)
2207 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2208 # This assumes that no other private flags equal 128, and that
2209 # OPs that store things other than flags in their op_private,
2210 # like OP_AELEMFAST, won't be immediate children of a list.
2212 # OP_ENTERSUB can break this logic, so check for it.
2213 # I suspect that open and exit can too.
2215 if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
2216 or $lop->name eq "undef")
2217 or $lop->name eq "entersub"
2218 or $lop->name eq "exit"
2219 or $lop->name eq "open")
2221 $local = ""; # or not
2224 if ($lop->name =~ /^pad[ash]v$/) { # my()
2225 ($local = "", last) if $local eq "local" || $local eq "our";
2227 } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
2228 && $lop->private & OPpOUR_INTRO
2229 or $lop->name eq "null" && $lop->first->name eq "gvsv"
2230 && $lop->first->private & OPpOUR_INTRO) { # our()
2231 ($local = "", last) if $local eq "my" || $local eq "local";
2233 } elsif ($lop->name ne "undef") { # local()
2234 ($local = "", last) if $local eq "my" || $local eq "our";
2238 $local = "" if $local eq "either"; # no point if it's all undefs
2239 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2240 for (; !null($kid); $kid = $kid->sibling) {
2242 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2247 $self->{'avoid_local'}{$$lop}++;
2248 $expr = $self->deparse($kid, 6);
2249 delete $self->{'avoid_local'}{$$lop};
2251 $expr = $self->deparse($kid, 6);
2256 return "$local(" . join(", ", @exprs) . ")";
2258 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2262 sub is_ifelse_cont {
2264 return ($op->name eq "null" and class($op) eq "UNOP"
2265 and $op->first->name =~ /^(and|cond_expr)$/
2266 and is_scope($op->first->first->sibling));
2272 my $cond = $op->first;
2273 my $true = $cond->sibling;
2274 my $false = $true->sibling;
2275 my $cuddle = $self->{'cuddle'};
2276 unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
2277 (is_scope($false) || is_ifelse_cont($false))
2278 and $self->{'expand'} < 7) {
2279 $cond = $self->deparse($cond, 8);
2280 $true = $self->deparse($true, 8);
2281 $false = $self->deparse($false, 8);
2282 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2285 $cond = $self->deparse($cond, 1);
2286 $true = $self->deparse($true, 0);
2287 my $head = "if ($cond) {\n\t$true\n\b}";
2289 while (!null($false) and is_ifelse_cont($false)) {
2290 my $newop = $false->first;
2291 my $newcond = $newop->first;
2292 my $newtrue = $newcond->sibling;
2293 $false = $newtrue->sibling; # last in chain is OP_AND => no else
2294 $newcond = $self->deparse($newcond, 1);
2295 $newtrue = $self->deparse($newtrue, 0);
2296 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2298 if (!null($false)) {
2299 $false = $cuddle . "else {\n\t" .
2300 $self->deparse($false, 0) . "\n\b}\cK";
2304 return $head . join($cuddle, "", @elsifs) . $false;
2309 my($op, $cx, $init) = @_;
2310 my $enter = $op->first;
2311 my $kid = $enter->sibling;
2312 local(@$self{qw'curstash warnings hints'})
2313 = @$self{qw'curstash warnings hints'};
2318 if ($kid->name eq "lineseq") { # bare or infinite loop
2319 if (is_state $kid->last) { # infinite
2320 $head = "while (1) "; # Can't use for(;;) if there's a continue
2326 } elsif ($enter->name eq "enteriter") { # foreach
2327 my $ary = $enter->first->sibling; # first was pushmark
2328 my $var = $ary->sibling;
2329 if ($enter->flags & OPf_STACKED
2330 and not null $ary->first->sibling->sibling)
2332 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2333 $self->deparse($ary->first->sibling->sibling, 9);
2335 $ary = $self->deparse($ary, 1);
2338 if ($enter->flags & OPf_SPECIAL) { # thread special var
2339 $var = $self->pp_threadsv($enter, 1);
2340 } else { # regular my() variable
2341 $var = $self->pp_padsv($enter, 1);
2342 if ($self->padname_sv($enter->targ)->IVX ==
2343 $kid->first->first->sibling->last->cop_seq)
2345 # If the scope of this variable closes at the last
2346 # statement of the loop, it must have been
2348 $var = "my " . $var;
2351 } elsif ($var->name eq "rv2gv") {
2352 $var = $self->pp_rv2sv($var, 1);
2353 } elsif ($var->name eq "gv") {
2354 $var = "\$" . $self->deparse($var, 1);
2356 $head = "foreach $var ($ary) ";
2357 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2358 } elsif ($kid->name eq "null") { # while/until
2360 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2361 $cond = $self->deparse($kid->first, 1);
2362 $head = "$name ($cond) ";
2363 $body = $kid->first->sibling;
2364 } elsif ($kid->name eq "stub") { # bare and empty
2365 return "{;}"; # {} could be a hashref
2367 # If there isn't a continue block, then the next pointer for the loop
2368 # will point to the unstack, which is kid's penultimate child, except
2369 # in a bare loop, when it will point to the leaveloop. When neither of
2370 # these conditions hold, then the third-to-last child in the continue
2371 # block (or the last in a bare loop).
2372 my $cont_start = $enter->nextop;
2374 if ($$cont_start != $$op && ${$cont_start->sibling} != ${$body->last}) {
2376 $cont = $body->last;
2378 $cont = $body->first;
2379 while (!null($cont->sibling->sibling->sibling)) {
2380 $cont = $cont->sibling;
2383 my $state = $body->first;
2384 my $cuddle = $self->{'cuddle'};
2386 for (; $$state != $$cont; $state = $state->sibling) {
2387 push @states, $state;
2389 $body = $self->lineseq(undef, @states);
2390 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2391 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2394 $cont = $cuddle . "continue {\n\t" .
2395 $self->deparse($cont, 0) . "\n\b}\cK";
2398 return "" if !defined $body;
2400 $head = "for ($init; $cond;) ";
2403 $body = $self->deparse($body, 0);
2405 $body =~ s/;?$/;\n/;
2407 return $head . "{\n\t" . $body . "\b}" . $cont;
2410 sub pp_leaveloop { loop_common(@_, "") }
2415 my $init = $self->deparse($op, 1);
2416 return $self->loop_common($op->sibling->first->sibling, $cx, $init);
2421 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2424 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2425 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2430 if (class($op) eq "OP") {
2432 return $self->{'ex_const'} if $op->targ == OP_CONST;
2433 } elsif ($op->first->name eq "pushmark") {
2434 return $self->pp_list($op, $cx);
2435 } elsif ($op->first->name eq "enter") {
2436 return $self->pp_leave($op, $cx);
2437 } elsif ($op->targ == OP_STRINGIFY) {
2438 return $self->dquote($op, $cx);
2439 } elsif (!null($op->first->sibling) and
2440 $op->first->sibling->name eq "readline" and
2441 $op->first->sibling->flags & OPf_STACKED) {
2442 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2443 . $self->deparse($op->first->sibling, 7),
2445 } elsif (!null($op->first->sibling) and
2446 $op->first->sibling->name eq "trans" and
2447 $op->first->sibling->flags & OPf_STACKED) {
2448 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2449 . $self->deparse($op->first->sibling, 20),
2451 } elsif ($op->flags & OPf_SPECIAL && $cx == 0 && !$op->targ) {
2452 return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
2454 return $self->deparse($op->first, $cx);
2461 return $self->padname_sv($targ)->PVX;
2467 return substr($self->padname($op->targ), 1); # skip $/@/%
2473 return $self->maybe_my($op, $cx, $self->padname($op->targ));
2476 sub pp_padav { pp_padsv(@_) }
2477 sub pp_padhv { pp_padsv(@_) }
2482 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2483 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2484 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2491 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
2497 if (class($op) eq "PADOP") {
2498 return $self->padval($op->padix);
2499 } else { # class($op) eq "SVOP"
2507 my $gv = $self->gv_or_padgv($op);
2508 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2509 $self->gv_name($gv)));
2515 my $gv = $self->gv_or_padgv($op);
2516 return $self->gv_name($gv);
2522 my $gv = $self->gv_or_padgv($op);
2523 my $name = $self->gv_name($gv);
2524 $name = $self->{'curstash'}."::$name"
2525 if $name !~ /::/ && $self->lex_in_scope('@'.$name);
2527 return "\$" . $name . "[" .
2528 ($op->private + $self->{'arybase'}) . "]";
2533 my($op, $cx, $type) = @_;
2534 my $kid = $op->first;
2535 my $str = $self->deparse($kid, 0);
2536 return $self->stash_variable($type, $str) if is_scalar($kid);
2537 return $type ."{$str}";
2540 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2541 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2542 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2548 if ($op->first->name eq "padav") {
2549 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2551 return $self->maybe_local($op, $cx,
2552 $self->rv2x($op->first, $cx, '$#'));
2556 # skip down to the old, ex-rv2cv
2557 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
2562 my $kid = $op->first;
2563 if ($kid->name eq "const") { # constant list
2564 my $av = $self->const_sv($kid);
2565 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2567 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2571 sub is_subscriptable {
2573 if ($op->name =~ /^[ahg]elem/) {
2575 } elsif ($op->name eq "entersub") {
2576 my $kid = $op->first;
2577 return 0 unless null $kid->sibling;
2579 $kid = $kid->sibling until null $kid->sibling;
2580 return 0 if is_scope($kid);
2582 return 0 if $kid->name eq "gv";
2583 return 0 if is_scalar($kid);
2584 return is_subscriptable($kid);
2592 my ($op, $cx, $left, $right, $padname) = @_;
2593 my($array, $idx) = ($op->first, $op->first->sibling);
2594 unless ($array->name eq $padname) { # Maybe this has been fixed
2595 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2597 if ($array->name eq $padname) {
2598 $array = $self->padany($array);
2599 } elsif (is_scope($array)) { # ${expr}[0]
2600 $array = "{" . $self->deparse($array, 0) . "}";
2601 } elsif ($array->name eq "gv") {
2602 $array = $self->gv_name($self->gv_or_padgv($array));
2603 if ($array !~ /::/) {
2604 my $prefix = ($left eq '[' ? '@' : '%');
2605 $array = $self->{curstash}.'::'.$array
2606 if $self->lex_in_scope($prefix . $array);
2608 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2609 $array = $self->deparse($array, 24);
2611 # $x[20][3]{hi} or expr->[20]
2612 my $arrow = is_subscriptable($array) ? "" : "->";
2613 return $self->deparse($array, 24) . $arrow .
2614 $left . $self->deparse($idx, 1) . $right;
2616 $idx = $self->deparse($idx, 1);
2618 # Outer parens in an array index will confuse perl
2619 # if we're interpolating in a regular expression, i.e.
2620 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2622 # If $self->{parens}, then an initial '(' will
2623 # definitely be paired with a final ')'. If
2624 # !$self->{parens}, the misleading parens won't
2625 # have been added in the first place.
2627 # [You might think that we could get "(...)...(...)"
2628 # where the initial and final parens do not match
2629 # each other. But we can't, because the above would
2630 # only happen if there's an infix binop between the
2631 # two pairs of parens, and *that* means that the whole
2632 # expression would be parenthesized as well.]
2634 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2636 return "\$" . $array . $left . $idx . $right;
2639 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2640 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2645 my($glob, $part) = ($op->first, $op->last);
2646 $glob = $glob->first; # skip rv2gv
2647 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2648 my $scope = is_scope($glob);
2649 $glob = $self->deparse($glob, 0);
2650 $part = $self->deparse($part, 1);
2651 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2656 my ($op, $cx, $left, $right, $regname, $padname) = @_;
2658 my(@elems, $kid, $array, $list);
2659 if (class($op) eq "LISTOP") {
2661 } else { # ex-hslice inside delete()
2662 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2666 $array = $array->first
2667 if $array->name eq $regname or $array->name eq "null";
2668 if (is_scope($array)) {
2669 $array = "{" . $self->deparse($array, 0) . "}";
2670 } elsif ($array->name eq $padname) {
2671 $array = $self->padany($array);
2673 $array = $self->deparse($array, 24);
2675 $kid = $op->first->sibling; # skip pushmark
2676 if ($kid->name eq "list") {
2677 $kid = $kid->first->sibling; # skip list, pushmark
2678 for (; !null $kid; $kid = $kid->sibling) {
2679 push @elems, $self->deparse($kid, 6);
2681 $list = join(", ", @elems);
2683 $list = $self->deparse($kid, 1);
2685 return "\@" . $array . $left . $list . $right;
2688 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2689 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2694 my $idx = $op->first;
2695 my $list = $op->last;
2697 $list = $self->deparse($list, 1);
2698 $idx = $self->deparse($idx, 1);
2699 return "($list)" . "[$idx]";
2704 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2709 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2715 my $kid = $op->first->sibling; # skip pushmark
2716 my($meth, $obj, @exprs);
2717 if ($kid->name eq "list" and want_list $kid) {
2718 # When an indirect object isn't a bareword but the args are in
2719 # parens, the parens aren't part of the method syntax (the LLAFR
2720 # doesn't apply), but they make a list with OPf_PARENS set that
2721 # doesn't get flattened by the append_elem that adds the method,
2722 # making a (object, arg1, arg2, ...) list where the object
2723 # usually is. This can be distinguished from
2724 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2725 # object) because in the later the list is in scalar context
2726 # as the left side of -> always is, while in the former
2727 # the list is in list context as method arguments always are.
2728 # (Good thing there aren't method prototypes!)
2729 $meth = $kid->sibling;
2730 $kid = $kid->first->sibling; # skip pushmark
2732 $kid = $kid->sibling;
2733 for (; not null $kid; $kid = $kid->sibling) {
2734 push @exprs, $self->deparse($kid, 6);
2738 $kid = $kid->sibling;
2739 for (; not null $kid->sibling; $kid = $kid->sibling) {
2740 push @exprs, $self->deparse($kid, 6);
2744 $obj = $self->deparse($obj, 24);
2745 if ($meth->name eq "method_named") {
2746 $meth = $self->const_sv($meth)->PV;
2748 $meth = $meth->first;
2749 if ($meth->name eq "const") {
2750 # As of 5.005_58, this case is probably obsoleted by the
2751 # method_named case above
2752 $meth = $self->const_sv($meth)->PV; # needs to be bare
2754 $meth = $self->deparse($meth, 1);
2757 my $args = join(", ", @exprs);
2758 $kid = $obj . "->" . $meth;
2760 return $kid . "(" . $args . ")"; # parens mandatory
2766 # returns "&" if the prototype doesn't match the args,
2767 # or ("", $args_after_prototype_demunging) if it does.
2770 my($proto, @args) = @_;
2774 # An unbackslashed @ or % gobbles up the rest of the args
2775 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2777 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2780 return "&" if @args;
2781 } elsif ($chr eq ";") {
2783 } elsif ($chr eq "@" or $chr eq "%") {
2784 push @reals, map($self->deparse($_, 6), @args);
2790 if (want_scalar $arg) {
2791 push @reals, $self->deparse($arg, 6);
2795 } elsif ($chr eq "&") {
2796 if ($arg->name =~ /^(s?refgen|undef)$/) {
2797 push @reals, $self->deparse($arg, 6);
2801 } elsif ($chr eq "*") {
2802 if ($arg->name =~ /^s?refgen$/
2803 and $arg->first->first->name eq "rv2gv")
2805 $real = $arg->first->first; # skip refgen, null
2806 if ($real->first->name eq "gv") {
2807 push @reals, $self->deparse($real, 6);
2809 push @reals, $self->deparse($real->first, 6);
2814 } elsif (substr($chr, 0, 1) eq "\\") {
2815 $chr = substr($chr, 1);
2816 if ($arg->name =~ /^s?refgen$/ and
2817 !null($real = $arg->first) and
2818 ($chr eq "\$" && is_scalar($real->first)
2820 && $real->first->sibling->name
2823 && $real->first->sibling->name
2825 #or ($chr eq "&" # This doesn't work
2826 # && $real->first->name eq "rv2cv")
2828 && $real->first->name eq "rv2gv")))
2830 push @reals, $self->deparse($real, 6);
2837 return "&" if $proto and !$doneok; # too few args and no `;'
2838 return "&" if @args; # too many args
2839 return ("", join ", ", @reals);
2845 return $self->method($op, $cx) unless null $op->first->sibling;
2849 if ($op->flags & OPf_SPECIAL) {
2851 } elsif ($op->private & OPpENTERSUB_AMPER) {
2855 $kid = $kid->first->sibling; # skip ex-list, pushmark
2856 for (; not null $kid->sibling; $kid = $kid->sibling) {
2861 if (is_scope($kid)) {
2863 $kid = "{" . $self->deparse($kid, 0) . "}";
2864 } elsif ($kid->first->name eq "gv") {
2865 my $gv = $self->gv_or_padgv($kid->first);
2866 if (class($gv->CV) ne "SPECIAL") {
2867 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2869 $simple = 1; # only calls of named functions can be prototyped
2870 $kid = $self->deparse($kid, 24);
2871 } elsif (is_scalar $kid->first) {
2873 $kid = $self->deparse($kid, 24);
2876 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2877 $kid = $self->deparse($kid, 24) . $arrow;
2880 # Doesn't matter how many prototypes there are, if
2881 # they haven't happened yet!
2882 my $declared = exists $self->{'subs_declared'}{$kid};
2883 if (!$declared && defined($proto)) {
2884 # Avoid "too early to check prototype" warning
2885 ($amper, $proto) = ('&');
2889 if ($declared and defined $proto and not $amper) {
2890 ($amper, $args) = $self->check_proto($proto, @exprs);
2891 if ($amper eq "&") {
2892 $args = join(", ", map($self->deparse($_, 6), @exprs));
2895 $args = join(", ", map($self->deparse($_, 6), @exprs));
2897 if ($prefix or $amper) {
2898 if ($op->flags & OPf_STACKED) {
2899 return $prefix . $amper . $kid . "(" . $args . ")";
2901 return $prefix . $amper. $kid;
2904 # glob() invocations can be translated into calls of
2905 # CORE::GLOBAL::glob with an second parameter, a number.
2907 if ($kid eq "CORE::GLOBAL::glob") {
2909 $args =~ s/\s*,[^,]+$//;
2912 # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
2913 # so it must have been translated from a keyword call. Translate
2915 $kid =~ s/^CORE::GLOBAL:://;
2918 return "$kid(" . $args . ")";
2919 } elsif (defined $proto and $proto eq "") {
2921 } elsif (defined $proto and $proto eq "\$" and is_scalar($exprs[0])) {
2922 return $self->maybe_parens_func($kid, $args, $cx, 16);
2923 } elsif (defined($proto) && $proto or $simple) {
2924 return $self->maybe_parens_func($kid, $args, $cx, 5);
2926 return "$kid(" . $args . ")";
2931 sub pp_enterwrite { unop(@_, "write") }
2933 # escape things that cause interpolation in double quotes,
2934 # but not character escapes
2937 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
2941 # the same, but treat $|, $), $( and $ at the end of the string differently
2946 # Matches any string which is balanced with respect to {braces}
2966 (\(\?\??\{$bal\}\)) # $4
2972 /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
2977 # character escapes, but not delimiters that might need to be escaped
2978 sub escape_str { # ASCII, UTF8
2980 $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
2982 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2988 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2989 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2993 # Don't do this for regexen
2996 $str =~ s/\\/\\\\/g;
3000 # Remove backslashes which precede literal control characters,
3001 # to avoid creating ambiguity when we escape the latter.
3005 # the insane complexity here is due to the behaviour of "\c\"
3006 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
3010 sub balanced_delim {
3012 my @str = split //, $str;
3013 my($ar, $open, $close, $fail, $c, $cnt);
3014 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
3015 ($open, $close) = @$ar;
3016 $fail = 0; $cnt = 0;
3020 } elsif ($c eq $close) {
3029 $fail = 1 if $cnt != 0;
3030 return ($open, "$open$str$close") if not $fail;
3036 my($q, $default, $str) = @_;
3037 return "$default$str$default" if $default and index($str, $default) == -1;
3038 my($succeed, $delim);
3039 ($succeed, $str) = balanced_delim($str);
3040 return "$q$str" if $succeed;
3041 for $delim ('/', '"', '#') {
3042 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3045 $str =~ s/$default/\\$default/g;
3046 return "$default$str$default";
3055 if (class($sv) eq "SPECIAL") {
3056 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
3057 } elsif (class($sv) eq "NULL") {
3059 } elsif ($sv->FLAGS & SVf_IOK) {
3060 return $sv->int_value;
3061 } elsif ($sv->FLAGS & SVf_NOK) {
3063 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3064 return "\\(" . const($sv->RV) . ")"; # constant folded
3065 } elsif ($sv->FLAGS & SVf_POK) {
3067 if ($str =~ /[^ -~]/) { # ASCII for non-printing
3068 return single_delim("qq", '"', uninterp escape_str unback $str);
3070 return single_delim("q", "'", unback $str);
3081 # the constant could be in the pad (under useithreads)
3082 $sv = $self->padval($op->targ) unless $$sv;
3089 if ($op->private & OPpCONST_ARYBASE) {
3092 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3093 # return $self->const_sv($op)->PV;
3095 my $sv = $self->const_sv($op);
3096 # return const($sv);
3098 return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
3104 my $type = $op->name;
3105 if ($type eq "const") {
3106 return '$[' if $op->private & OPpCONST_ARYBASE;
3107 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3108 } elsif ($type eq "concat") {
3109 my $first = $self->dq($op->first);
3110 my $last = $self->dq($op->last);
3111 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3112 if ($last =~ /^[A-Z\\\^\[\]_?]/) {
3113 $first =~ s/([\$@])\^$/${1}{^}/; # "${^}W" etc
3115 elsif ($last =~ /^[{\[\w]/) {
3116 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
3118 return $first . $last;
3119 } elsif ($type eq "uc") {
3120 return '\U' . $self->dq($op->first->sibling) . '\E';
3121 } elsif ($type eq "lc") {
3122 return '\L' . $self->dq($op->first->sibling) . '\E';
3123 } elsif ($type eq "ucfirst") {
3124 return '\u' . $self->dq($op->first->sibling);
3125 } elsif ($type eq "lcfirst") {
3126 return '\l' . $self->dq($op->first->sibling);
3127 } elsif ($type eq "quotemeta") {
3128 return '\Q' . $self->dq($op->first->sibling) . '\E';
3129 } elsif ($type eq "join") {
3130 return $self->deparse($op->last, 26); # was join($", @ary)
3132 return $self->deparse($op, 26);
3140 return single_delim("qx", '`', $self->dq($op->first->sibling));
3146 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3147 return $self->deparse($kid, $cx) if $self->{'unquote'};
3148 $self->maybe_targmy($kid, $cx,
3149 sub {single_delim("qq", '"', $self->dq($_[1]))});
3152 # OP_STRINGIFY is a listop, but it only ever has one arg
3153 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3155 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3156 # note that tr(from)/to/ is OK, but not tr/from/(to)
3158 my($from, $to) = @_;
3159 my($succeed, $delim);
3160 if ($from !~ m[/] and $to !~ m[/]) {
3161 return "/$from/$to/";
3162 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3163 if (($succeed, $to) = balanced_delim($to) and $succeed) {
3166 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3167 return "$from$delim$to$delim" if index($to, $delim) == -1;
3170 return "$from/$to/";
3173 for $delim ('/', '"', '#') { # note no '
3174 return "$delim$from$delim$to$delim"
3175 if index($to . $from, $delim) == -1;
3177 $from =~ s[/][\\/]g;
3179 return "/$from/$to/";
3183 # Only used by tr///, so backslashes hyphens
3186 if ($n == ord '\\') {
3188 } elsif ($n == ord "-") {
3190 } elsif ($n >= ord(' ') and $n <= ord('~')) {
3192 } elsif ($n == ord "\a") {
3194 } elsif ($n == ord "\b") {
3196 } elsif ($n == ord "\t") {
3198 } elsif ($n == ord "\n") {
3200 } elsif ($n == ord "\e") {
3202 } elsif ($n == ord "\f") {
3204 } elsif ($n == ord "\r") {
3206 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3207 return '\\c' . chr(ord("@") + $n);
3209 # return '\x' . sprintf("%02x", $n);
3210 return '\\' . sprintf("%03o", $n);
3216 my($str, $c, $tr) = ("");
3217 for ($c = 0; $c < @chars; $c++) {
3220 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3221 $chars[$c + 2] == $tr + 2)
3223 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3226 $str .= pchr($chars[$c]);
3232 sub tr_decode_byte {
3233 my($table, $flags) = @_;
3234 my(@table) = unpack("s*", $table);
3235 splice @table, 0x100, 1; # Just flags presence of element 0x101
3236 my($c, $tr, @from, @to, @delfrom, $delhyphen);
3237 if ($table[ord "-"] != -1 and
3238 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3240 $tr = $table[ord "-"];
3241 $table[ord "-"] = -1;
3245 } else { # -2 ==> delete
3249 for ($c = 0; $c < @table; $c++) {
3252 push @from, $c; push @to, $tr;
3253 } elsif ($tr == -2) {
3257 @from = (@from, @delfrom);
3258 if ($flags & OPpTRANS_COMPLEMENT) {
3261 @from{@from} = (1) x @from;
3262 for ($c = 0; $c < 256; $c++) {
3263 push @newfrom, $c unless $from{$c};
3267 unless ($flags & OPpTRANS_DELETE || !@to) {
3268 pop @to while $#to and $to[$#to] == $to[$#to -1];
3271 $from = collapse(@from);
3272 $to = collapse(@to);
3273 $from .= "-" if $delhyphen;
3274 return ($from, $to);
3279 if ($x == ord "-") {
3281 } elsif ($x == ord "\\") {
3288 # XXX This doesn't yet handle all cases correctly either
3290 sub tr_decode_utf8 {
3291 my($swash_hv, $flags) = @_;
3292 my %swash = $swash_hv->ARRAY;
3294 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3295 my $none = $swash{"NONE"}->IV;
3296 my $extra = $none + 1;
3297 my(@from, @delfrom, @to);
3299 foreach $line (split /\n/, $swash{'LIST'}->PV) {
3300 my($min, $max, $result) = split(/\t/, $line);
3307 $result = hex $result;
3308 if ($result == $extra) {
3309 push @delfrom, [$min, $max];
3311 push @from, [$min, $max];
3312 push @to, [$result, $result + $max - $min];
3315 for my $i (0 .. $#from) {
3316 if ($from[$i][0] == ord '-') {
3317 unshift @from, splice(@from, $i, 1);
3318 unshift @to, splice(@to, $i, 1);
3320 } elsif ($from[$i][1] == ord '-') {
3323 unshift @from, ord '-';
3324 unshift @to, ord '-';
3328 for my $i (0 .. $#delfrom) {
3329 if ($delfrom[$i][0] == ord '-') {
3330 push @delfrom, splice(@delfrom, $i, 1);
3332 } elsif ($delfrom[$i][1] == ord '-') {
3334 push @delfrom, ord '-';
3338 if (defined $final and $to[$#to][1] != $final) {
3339 push @to, [$final, $final];
3341 push @from, @delfrom;
3342 if ($flags & OPpTRANS_COMPLEMENT) {
3345 for my $i (0 .. $#from) {
3346 push @newfrom, [$next, $from[$i][0] - 1];
3347 $next = $from[$i][1] + 1;
3350 for my $range (@newfrom) {
3351 if ($range->[0] <= $range->[1]) {
3356 my($from, $to, $diff);
3357 for my $chunk (@from) {
3358 $diff = $chunk->[1] - $chunk->[0];
3360 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3361 } elsif ($diff == 1) {
3362 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3364 $from .= tr_chr($chunk->[0]);
3367 for my $chunk (@to) {
3368 $diff = $chunk->[1] - $chunk->[0];
3370 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3371 } elsif ($diff == 1) {
3372 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3374 $to .= tr_chr($chunk->[0]);
3377 #$final = sprintf("%04x", $final) if defined $final;
3378 #$none = sprintf("%04x", $none) if defined $none;
3379 #$extra = sprintf("%04x", $extra) if defined $extra;
3380 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3381 #print STDERR $swash{'LIST'}->PV;
3382 return (escape_str($from), escape_str($to));
3389 if (class($op) eq "PVOP") {
3390 ($from, $to) = tr_decode_byte($op->pv, $op->private);
3391 } else { # class($op) eq "SVOP"
3392 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3395 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3396 $flags .= "d" if $op->private & OPpTRANS_DELETE;
3397 $to = "" if $from eq $to and $flags eq "";
3398 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3399 return "tr" . double_delim($from, $to) . $flags;
3402 # Like dq(), but different
3406 my $type = $op->name;
3407 if ($type eq "const") {
3408 return '$[' if $op->private & OPpCONST_ARYBASE;
3409 return re_uninterp(escape_str(re_unback($self->const_sv($op)->as_string)));
3410 } elsif ($type eq "concat") {
3411 my $first = $self->re_dq($op->first);
3412 my $last = $self->re_dq($op->last);
3413 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3414 if ($last =~ /^[A-Z\\\^\[\]_?]/) {
3415 $first =~ s/([\$@])\^$/${1}{^}/;
3417 elsif ($last =~ /^[{\[\w]/) {
3418 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
3420 return $first . $last;
3421 } elsif ($type eq "uc") {
3422 return '\U' . $self->re_dq($op->first->sibling) . '\E';
3423 } elsif ($type eq "lc") {
3424 return '\L' . $self->re_dq($op->first->sibling) . '\E';
3425 } elsif ($type eq "ucfirst") {
3426 return '\u' . $self->re_dq($op->first->sibling);
3427 } elsif ($type eq "lcfirst") {
3428 return '\l' . $self->re_dq($op->first->sibling);
3429 } elsif ($type eq "quotemeta") {
3430 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
3431 } elsif ($type eq "join") {
3432 return $self->deparse($op->last, 26); # was join($", @ary)
3434 return $self->deparse($op, 26);
3441 my $kid = $op->first;
3442 $kid = $kid->first if $kid->name eq "regcmaybe";
3443 $kid = $kid->first if $kid->name eq "regcreset";
3444 return $self->re_dq($kid);
3447 # osmic acid -- see osmium tetroxide
3450 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3451 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3452 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3456 my($op, $cx, $name, $delim) = @_;
3457 my $kid = $op->first;
3458 my ($binop, $var, $re) = ("", "", "");
3459 if ($op->flags & OPf_STACKED) {
3461 $var = $self->deparse($kid, 20);
3462 $kid = $kid->sibling;
3465 $re = re_unback($op->precomp);
3466 $re = re_uninterp(escape_str($re)) unless $op->pmflags & PMf_EXTENDED;
3468 $re = $self->deparse($kid, 1);
3471 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3472 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3473 $flags .= "i" if $op->pmflags & PMf_FOLD;
3474 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3475 $flags .= "o" if $op->pmflags & PMf_KEEP;
3476 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3477 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3478 $flags = $matchwords{$flags} if $matchwords{$flags};
3479 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3483 $re = single_delim($name, $delim, $re);
3487 return $self->maybe_parens("$var =~ $re", $cx, 20);
3493 sub pp_match { matchop(@_, "m", "/") }
3494 sub pp_pushre { matchop(@_, "m", "/") }
3495 sub pp_qr { matchop(@_, "qr", "") }
3500 my($kid, @exprs, $ary, $expr);
3502 if ($ {$kid->pmreplroot}) {
3503 $ary = $self->stash_variable('@', $self->gv_name($kid->pmreplroot));
3505 for (; !null($kid); $kid = $kid->sibling) {
3506 push @exprs, $self->deparse($kid, 6);
3509 # handle special case of split(), and split(" ") that compiles to /\s+/
3511 if ($kid->flags & OPf_SPECIAL
3512 && $exprs[0] eq '/\\s+/'
3513 && $kid->pmflags & PMf_SKIPWHITE ) {
3517 $expr = "split(" . join(", ", @exprs) . ")";
3519 return $self->maybe_parens("$ary = $expr", $cx, 7);
3525 # oxime -- any of various compounds obtained chiefly by the action of
3526 # hydroxylamine on aldehydes and ketones and characterized by the
3527 # bivalent grouping C=NOH [Webster's Tenth]
3530 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3531 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3532 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3533 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3538 my $kid = $op->first;
3539 my($binop, $var, $re, $repl) = ("", "", "", "");
3540 if ($op->flags & OPf_STACKED) {
3542 $var = $self->deparse($kid, 20);
3543 $kid = $kid->sibling;
3546 if (null($op->pmreplroot)) {
3547 $repl = $self->dq($kid);
3548 $kid = $kid->sibling;
3550 $repl = $op->pmreplroot->first; # skip substcont
3551 while ($repl->name eq "entereval") {
3552 $repl = $repl->first;
3555 if ($op->pmflags & PMf_EVAL) {
3556 $repl = $self->deparse($repl, 0);
3558 $repl = $self->dq($repl);
3562 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3564 $re = $self->deparse($kid, 1);
3566 $flags .= "e" if $op->pmflags & PMf_EVAL;
3567 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3568 $flags .= "i" if $op->pmflags & PMf_FOLD;
3569 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3570 $flags .= "o" if $op->pmflags & PMf_KEEP;
3571 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3572 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3573 $flags = $substwords{$flags} if $substwords{$flags};
3575 return $self->maybe_parens("$var =~ s"
3576 . double_delim($re, $repl) . $flags,
3579 return "s". double_delim($re, $repl) . $flags;
3588 B::Deparse - Perl compiler backend to produce perl code
3592 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3593 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3597 B::Deparse is a backend module for the Perl compiler that generates
3598 perl source code, based on the internal compiled structure that perl
3599 itself creates after parsing a program. The output of B::Deparse won't
3600 be exactly the same as the original source, since perl doesn't keep
3601 track of comments or whitespace, and there isn't a one-to-one
3602 correspondence between perl's syntactical constructions and their
3603 compiled form, but it will often be close. When you use the B<-p>
3604 option, the output also includes parentheses even when they are not
3605 required by precedence, which can make it easy to see if perl is
3606 parsing your expressions the way you intended.
3608 Please note that this module is mainly new and untested code and is
3609 still under development, so it may change in the future.
3613 As with all compiler backend options, these must follow directly after
3614 the '-MO=Deparse', separated by a comma but not any white space.
3620 Add '#line' declarations to the output based on the line and file
3621 locations of the original code.
3625 Print extra parentheses. Without this option, B::Deparse includes
3626 parentheses in its output only when they are needed, based on the
3627 structure of your program. With B<-p>, it uses parentheses (almost)
3628 whenever they would be legal. This can be useful if you are used to
3629 LISP, or if you want to see how perl parses your input. If you say
3631 if ($var & 0x7f == 65) {print "Gimme an A!"}
3632 print ($which ? $a : $b), "\n";
3633 $name = $ENV{USER} or "Bob";
3635 C<B::Deparse,-p> will print
3638 print('Gimme an A!')
3640 (print(($which ? $a : $b)), '???');
3641 (($name = $ENV{'USER'}) or '???')
3643 which probably isn't what you intended (the C<'???'> is a sign that
3644 perl optimized away a constant value).
3648 Expand double-quoted strings into the corresponding combinations of
3649 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3652 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3656 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3657 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3659 Note that the expanded form represents the way perl handles such
3660 constructions internally -- this option actually turns off the reverse
3661 translation that B::Deparse usually does. On the other hand, note that
3662 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3663 of $y into a string before doing the assignment.
3667 Normally, B::Deparse deparses the main code of a program, and all the subs
3668 defined in the same file. To include subs defined in other files, pass the
3669 B<-f> option with the filename. You can pass the B<-f> option several times, to
3670 include more than one secondary file. (Most of the time you don't want to
3671 use it at all.) You can also use this option to include subs which are
3672 defined in the scope of a B<#line> directive with two parameters.
3674 =item B<-s>I<LETTERS>
3676 Tweak the style of B::Deparse's output. The letters should follow
3677 directly after the 's', with no space or punctuation. The following
3678 options are available:
3684 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3701 The default is not to cuddle.
3705 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3709 Use tabs for each 8 columns of indent. The default is to use only spaces.
3710 For instance, if the style options are B<-si4T>, a line that's indented
3711 3 times will be preceded by one tab and four spaces; if the options were
3712 B<-si8T>, the same line would be preceded by three tabs.
3714 =item B<v>I<STRING>B<.>
3716 Print I<STRING> for the value of a constant that can't be determined
3717 because it was optimized away (mnemonic: this happens when a constant
3718 is used in B<v>oid context). The end of the string is marked by a period.
3719 The string should be a valid perl expression, generally a constant.
3720 Note that unless it's a number, it probably needs to be quoted, and on
3721 a command line quotes need to be protected from the shell. Some
3722 conventional values include 0, 1, 42, '', 'foo', and
3723 'Useless use of constant omitted' (which may need to be
3724 B<-sv"'Useless use of constant omitted'.">
3725 or something similar depending on your shell). The default is '???'.
3726 If you're using B::Deparse on a module or other file that's require'd,
3727 you shouldn't use a value that evaluates to false, since the customary
3728 true constant at the end of a module will be in void context when the
3729 file is compiled as a main program.
3735 Expand conventional syntax constructions into equivalent ones that expose
3736 their internal operation. I<LEVEL> should be a digit, with higher values
3737 meaning more expansion. As with B<-q>, this actually involves turning off
3738 special cases in B::Deparse's normal operations.
3740 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3741 while loops with continue blocks; for instance
3743 for ($i = 0; $i < 10; ++$i) {
3756 Note that in a few cases this translation can't be perfectly carried back
3757 into the source code -- if the loop's initializer declares a my variable,
3758 for instance, it won't have the correct scope outside of the loop.
3760 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3761 expressions using C<&&>, C<?:> and C<do {}>; for instance
3763 print 'hi' if $nice;
3775 $nice and print 'hi';
3776 $nice and do { print 'hi' };
3777 $nice ? do { print 'hi' } : do { print 'bye' };
3779 Long sequences of elsifs will turn into nested ternary operators, which
3780 B::Deparse doesn't know how to indent nicely.
3784 =head1 USING B::Deparse AS A MODULE
3789 $deparse = B::Deparse->new("-p", "-sC");
3790 $body = $deparse->coderef2text(\&func);
3791 eval "sub func $body"; # the inverse operation
3795 B::Deparse can also be used on a sub-by-sub basis from other perl
3800 $deparse = B::Deparse->new(OPTIONS)
3802 Create an object to store the state of a deparsing operation and any
3803 options. The options are the same as those that can be given on the
3804 command line (see L</OPTIONS>); options that are separated by commas
3805 after B<-MO=Deparse> should be given as separate strings. Some
3806 options, like B<-u>, don't make sense for a single subroutine, so
3809 =head2 ambient_pragmas
3811 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3813 The compilation of a subroutine can be affected by a few compiler
3814 directives, B<pragmas>. These are:
3828 Assigning to the special variable $[
3848 Ordinarily, if you use B::Deparse on a subroutine which has
3849 been compiled in the presence of one or more of these pragmas,
3850 the output will include statements to turn on the appropriate
3851 directives. So if you then compile the code returned by coderef2text,
3852 it will behave the same way as the subroutine which you deparsed.
3854 However, you may know that you intend to use the results in a
3855 particular context, where some pragmas are already in scope. In
3856 this case, you use the B<ambient_pragmas> method to describe the
3857 assumptions you wish to make.
3859 Not all of the options currently have any useful effect. See
3860 L</BUGS> for more details.
3862 The parameters it accepts are:
3868 Takes a string, possibly containing several values separated
3869 by whitespace. The special values "all" and "none" mean what you'd
3872 $deparse->ambient_pragmas(strict => 'subs refs');
3876 Takes a number, the value of the array base $[.
3884 If the value is true, then the appropriate pragma is assumed to
3885 be in the ambient scope, otherwise not.
3889 Takes a string, possibly containing a whitespace-separated list of
3890 values. The values "all" and "none" are special. It's also permissible
3891 to pass an array reference here.
3893 $deparser->ambient_pragmas(re => 'eval');
3898 Takes a string, possibly containing a whitespace-separated list of
3899 values. The values "all" and "none" are special, again. It's also
3900 permissible to pass an array reference here.
3902 $deparser->ambient_pragmas(warnings => [qw[void io]]);
3904 If one of the values is the string "FATAL", then all the warnings
3905 in that list will be considered fatal, just as with the B<warnings>
3906 pragma itself. Should you need to specify that some warnings are
3907 fatal, and others are merely enabled, you can pass the B<warnings>
3910 $deparser->ambient_pragmas(
3912 warnings => [FATAL => qw/void io/],
3915 See L<perllexwarn> for more information about lexical warnings.
3921 These two parameters are used to specify the ambient pragmas in
3922 the format used by the special variables $^H and ${^WARNING_BITS}.
3924 They exist principally so that you can write code like:
3926 { my ($hint_bits, $warning_bits);
3927 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
3928 $deparser->ambient_pragmas (
3929 hint_bits => $hint_bits,
3930 warning_bits => $warning_bits,
3934 which specifies that the ambient pragmas are exactly those which
3935 are in scope at the point of calling.
3941 $body = $deparse->coderef2text(\&func)
3942 $body = $deparse->coderef2text(sub ($$) { ... })
3944 Return source code for the body of a subroutine (a block, optionally
3945 preceded by a prototype in parens), given a reference to the
3946 sub. Because a subroutine can have no names, or more than one name,
3947 this method doesn't return a complete subroutine definition -- if you
3948 want to eval the result, you should prepend "sub subname ", or "sub "
3949 for an anonymous function constructor. Unless the sub was defined in
3950 the main:: package, the code will include a package declaration.
3958 The only pragmas to be completely supported are: C<use warnings>,
3959 C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
3960 behaves like a pragma, is also supported.)
3962 Excepting those listed above, we're currently unable to guarantee that
3963 B::Deparse will produce a pragma at the correct point in the program.
3964 Since the effects of pragmas are often lexically scoped, this can mean
3965 that the pragma holds sway over a different portion of the program
3966 than in the input file.
3970 Lvalue method calls are not yet fully supported. (Ordinary lvalue
3971 subroutine calls ought to be okay though.)
3975 If you have a regex which is anything other than a literal of some
3976 kind, B::Deparse will produce incorrect output.
3977 e.g. C<$foo =~ give_me_a_regex()> will come back as
3978 C<$foo =~ /give_me_a_regex()/>
3993 If a keyword is over-ridden, and your program explicitly calls
3994 the built-in version by using CORE::keyword, the output of B::Deparse
3995 will not reflect this.
3999 C<sort foo (1, 2, 3)> comes out as C<sort (foo 1, 2, 3)>, which
4000 causes perl to issue a warning.
4002 The obvious fix doesn't work, because these are different:
4004 print (FOO 1, 2, 3), 4, 5, 6;
4005 print FOO (1, 2, 3), 4, 5, 6;
4009 Constants (other than simple strings or numbers) don't work properly.
4010 Examples that fail include:
4012 use constant E2BIG => ($!=7);
4013 use constant x=>\$x; print x
4017 An input file that uses source filtering probably won't be deparsed into
4018 runnable code, because it will still include the B<use> declaration
4019 for the source filtering module, even though the code that is
4020 produced is already ordinary Perl which shouldn't be filtered again.
4024 There are probably many more bugs on non-ASCII platforms (EBCDIC).
4030 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
4031 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
4032 contributions from Gisle Aas, James Duncan, Albert Dvornik, Robin
4033 Houston, Hugo van der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.