2 # Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved.
3 # This module is free software; you can redistribute and/or modify
4 # it under the same terms as Perl itself.
6 # This is based on the module of the same name by Malcolm Beattie,
7 # but essentially none of his code remains.
10 use Carp 'cluck', 'croak';
11 use B qw(class main_root main_start main_cv svref_2object opnumber cstring
12 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
13 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
14 OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
15 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
16 OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
18 SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR
19 CVf_METHOD CVf_LOCKED CVf_LVALUE
20 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
21 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
26 # Changes between 0.50 and 0.51:
27 # - fixed nulled leave with live enter in sort { }
28 # - fixed reference constants (\"str")
29 # - handle empty programs gracefully
30 # - handle infinte loops (for (;;) {}, while (1) {})
31 # - differentiate between `for my $x ...' and `my $x; for $x ...'
32 # - various minor cleanups
33 # - moved globals into an object
34 # - added `-u', like B::C
35 # - package declarations using cop_stash
36 # - subs, formats and code sorted by cop_seq
37 # Changes between 0.51 and 0.52:
38 # - added pp_threadsv (special variables under USE_THREADS)
39 # - added documentation
40 # Changes between 0.52 and 0.53:
41 # - many changes adding precedence contexts and associativity
42 # - added `-p' and `-s' output style options
43 # - various other minor fixes
44 # Changes between 0.53 and 0.54:
45 # - added support for new `for (1..100)' optimization,
47 # Changes between 0.54 and 0.55:
48 # - added support for new qr// construct
49 # - added support for new pp_regcreset OP
50 # Changes between 0.55 and 0.56:
51 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
52 # - fixed $# on non-lexicals broken in last big rewrite
53 # - added temporary fix for change in opcode of OP_STRINGIFY
54 # - fixed problem in 0.54's for() patch in `for (@ary)'
55 # - fixed precedence in conditional of ?:
56 # - tweaked list paren elimination in `my($x) = @_'
57 # - made continue-block detection trickier wrt. null ops
58 # - fixed various prototype problems in pp_entersub
59 # - added support for sub prototypes that never get GVs
60 # - added unquoting for special filehandle first arg in truncate
61 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
62 # - added semicolons at the ends of blocks
63 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
64 # Changes between 0.56 and 0.561:
65 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
66 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
67 # Changes between 0.561 and 0.57:
68 # - stylistic changes to symbolic constant stuff
69 # - handled scope in s///e replacement code
70 # - added unquote option for expanding "" into concats, etc.
71 # - split method and proto parts of pp_entersub into separate functions
72 # - various minor cleanups
74 # - added parens in \&foo (patch by Albert Dvornik)
75 # Changes between 0.57 and 0.58:
76 # - fixed `0' statements that weren't being printed
77 # - added methods for use from other programs
78 # (based on patches from James Duncan and Hugo van der Sanden)
79 # - added -si and -sT to control indenting (also based on a patch from Hugo)
80 # - added -sv to print something else instead of '???'
81 # - preliminary version of utf8 tr/// handling
83 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
84 # - added support for Hugo's new OP_SETSTATE (like nextstate)
85 # Changes between 0.58 and 0.59
86 # - added support for Chip's OP_METHOD_NAMED
87 # - added support for Ilya's OPpTARGET_MY optimization
88 # - elided arrows before `()' subscripts when possible
89 # Changes between 0.59 and 0.60
90 # - support for method attribues was added
91 # - some warnings fixed
92 # - separate recognition of constant subs
93 # - rewrote continue block handling, now recoginizing for loops
94 # - added more control of expanding control structures
95 # Changes between 0.60 and 0.61 (mostly by Robin Houston)
97 # - support for pragmas and 'use'
98 # - support for the little-used $[ variable
99 # - support for __DATA__ sections
101 # - BEGIN, CHECK, INIT and END blocks
102 # - scoping of subroutine declarations fixed
103 # - compile-time output from the input program can be suppressed, so that the
104 # output is just the deparsed code. (a change to O.pm in fact)
105 # - our() declarations
106 # - *all* the known bugs are now listed in the BUGS section
107 # - comprehensive test mechanism (TEST -deparse)
110 # (See also BUGS section at the end of this file)
112 # - finish tr/// changes
113 # - add option for even more parens (generalize \&foo change)
114 # - left/right context
115 # - treat top-level block specially for incremental output
116 # - copy comments (look at real text with $^P?)
117 # - avoid semis in one-statement blocks
118 # - associativity of &&=, ||=, ?:
119 # - ',' => '=>' (auto-unquote?)
120 # - break long lines ("\r" as discretionary break?)
121 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
122 # - more style options: brace style, hex vs. octal, quotes, ...
123 # - print big ints as hex/octal instead of decimal (heuristic?)
124 # - handle `my $x if 0'?
125 # - coordinate with Data::Dumper (both directions? see previous)
126 # - version using op_next instead of op_first/sibling?
127 # - avoid string copies (pass arrays, one big join?)
130 # Tests that will always fail:
131 # (see t/TEST for the short list)
133 # Object fields (were globals):
136 # (local($a), local($b)) and local($a, $b) have the same internal
137 # representation but the short form looks better. We notice we can
138 # use a large-scale local when checking the list, but need to prevent
139 # individual locals too. This hash holds the addresses of OPs that
140 # have already had their local-ness accounted for. The same thing
144 # CV for current sub (or main program) being deparsed
147 # Cached hash of lexical variables for curcv: keys are names,
148 # each value is an array of pairs, indicating the cop_seq of scopes
149 # in which a var of that name is valid.
152 # COP for statement being deparsed
155 # name of the current package for deparsed code
158 # array of [cop_seq, CV, is_format?] for subs and formats we still
162 # as above, but [name, prototype] for subs that never got a GV
164 # subs_done, forms_done:
165 # keys are addresses of GVs for subs and formats we've already
166 # deparsed (or at least put into subs_todo)
169 # keys are names of subs for which we've printed declarations.
170 # That means we can omit parentheses from the arguments.
175 # cuddle: ` ' or `\n', depending on -sC
180 # A little explanation of how precedence contexts and associativity
183 # deparse() calls each per-op subroutine with an argument $cx (short
184 # for context, but not the same as the cx* in the perl core), which is
185 # a number describing the op's parents in terms of precedence, whether
186 # they're inside an expression or at statement level, etc. (see
187 # chart below). When ops with children call deparse on them, they pass
188 # along their precedence. Fractional values are used to implement
189 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
190 # parentheses hacks. The major disadvantage of this scheme is that
191 # it doesn't know about right sides and left sides, so say if you
192 # assign a listop to a variable, it can't tell it's allowed to leave
193 # the parens off the listop.
196 # 26 [TODO] inside interpolation context ("")
197 # 25 left terms and list operators (leftward)
201 # 21 right ! ~ \ and unary + and -
206 # 16 nonassoc named unary operators
207 # 15 nonassoc < > <= >= lt gt le ge
208 # 14 nonassoc == != <=> eq ne cmp
215 # 7 right = += -= *= etc.
217 # 5 nonassoc list operators (rightward)
221 # 1 statement modifiers
224 # Also, lineseq may pass a fourth parameter to the pp_ routines:
225 # if present, the fourth parameter is passed on by deparse.
227 # If present and true, it means that the op exists directly as
228 # part of a lineseq. Currently it's only used by scopeop to
229 # decide whether its results need to be enclosed in a do {} block.
231 # Nonprinting characters with special meaning:
232 # \cS - steal parens (see maybe_parens_unop)
233 # \n - newline and indent
234 # \t - increase indent
235 # \b - decrease indent (`outdent')
236 # \f - flush left (no indent)
237 # \cK - kill following semicolon, if any
241 return class($op) eq "NULL";
246 my($cv, $is_form) = @_;
247 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
249 if (!null($cv->START) and is_state($cv->START)) {
250 $seq = $cv->START->cop_seq;
254 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
259 my $ent = shift @{$self->{'subs_todo'}};
262 my $name = $self->gv_name($gv);
264 return "format $name =\n"
265 . $self->deparse_format($ent->[1]). "\n";
267 $self->{'subs_declared'}{$name} = 1;
268 if ($name eq "BEGIN") {
269 my $use_dec = $self->begin_is_use($cv);
270 if (defined ($use_dec)) {
271 return () if 0 == length($use_dec);
276 if ($self->{'linenums'}) {
277 my $line = $gv->LINE;
278 my $file = $gv->FILE;
279 $l = "\n\f#line $line \"$file\"\n";
281 return "${l}sub $name " . $self->deparse_sub($cv);
285 # Return a "use" declaration for this BEGIN block, if appropriate
287 my ($self, $cv) = @_;
288 my $root = $cv->ROOT;
289 local @$self{qw'curcv curcvlex'} = ($cv);
291 #B::walkoptree($cv->ROOT, "debug");
292 my $lineseq = $root->first;
293 return if $lineseq->name ne "lineseq";
295 my $req_op = $lineseq->first->sibling;
296 return if $req_op->name ne "require";
299 if ($req_op->first->private & OPpCONST_BARE) {
300 # Actually it should always be a bareword
301 $module = $self->const_sv($req_op->first)->PV;
302 $module =~ s[/][::]g;
306 $module = const($self->const_sv($req_op->first));
310 my $version_op = $req_op->sibling;
311 return if class($version_op) eq "NULL";
312 if ($version_op->name eq "lineseq") {
313 # We have a version parameter; skip nextstate & pushmark
314 my $constop = $version_op->first->next->next;
316 return unless $self->const_sv($constop)->PV eq $module;
317 $constop = $constop->sibling;
318 $version = $self->const_sv($constop)->int_value;
319 $constop = $constop->sibling;
320 return if $constop->name ne "method_named";
321 return if $self->const_sv($constop)->PV ne "VERSION";
324 $lineseq = $version_op->sibling;
325 return if $lineseq->name ne "lineseq";
326 my $entersub = $lineseq->first->sibling;
327 if ($entersub->name eq "stub") {
328 return "use $module $version ();\n" if defined $version;
329 return "use $module ();\n";
331 return if $entersub->name ne "entersub";
333 # See if there are import arguments
336 my $svop = $entersub->first->sibling; # Skip over pushmark
337 return unless $self->const_sv($svop)->PV eq $module;
339 # Pull out the arguments
340 for ($svop=$svop->sibling; $svop->name ne "method_named";
341 $svop = $svop->sibling) {
342 $args .= ", " if length($args);
343 $args .= $self->deparse($svop, 6);
347 my $method_named = $svop;
348 return if $method_named->name ne "method_named";
349 my $method_name = $self->const_sv($method_named)->PV;
351 if ($method_name eq "unimport") {
355 # Certain pragmas are dealt with using hint bits,
356 # so we ignore them here
357 if ($module eq 'strict' || $module eq 'integer'
358 || $module eq 'bytes' || $module eq 'warnings') {
362 if (defined $version && length $args) {
363 return "$use $module $version ($args);\n";
364 } elsif (defined $version) {
365 return "$use $module $version;\n";
366 } elsif (length $args) {
367 return "$use $module ($args);\n";
369 return "$use $module;\n";
374 my ($self, $pack) = @_;
376 if (!defined $pack) {
381 $pack =~ s/(::)?$/::/;
385 my %stash = svref_2object($stash)->ARRAY;
386 while (my ($key, $val) = each %stash) {
387 next if $key eq 'main::'; # avoid infinite recursion
388 my $class = class($val);
389 if ($class eq "PV") {
390 # Just a prototype. As an ugly but fairly effective way
391 # to find out if it belongs here is to see if the AUTOLOAD
392 # (if any) for the stash was defined in one of our files.
393 my $A = $stash{"AUTOLOAD"};
394 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
395 && class($A->CV) eq "CV") {
397 next unless $AF eq $0 || exists $self->{'files'}{$AF};
399 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
400 } elsif ($class eq "IV") {
401 # Just a name. As above.
402 my $A = $stash{"AUTOLOAD"};
403 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
404 && class($A->CV) eq "CV") {
406 next unless $AF eq $0 || exists $self->{'files'}{$AF};
408 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
409 } elsif ($class eq "GV") {
410 if (class(my $cv = $val->CV) ne "SPECIAL") {
411 next if $self->{'subs_done'}{$$val}++;
412 next if $$val != ${$cv->GV}; # Ignore imposters
415 if (class(my $cv = $val->FORM) ne "SPECIAL") {
416 next if $self->{'forms_done'}{$$val}++;
417 next if $$val != ${$cv->GV}; # Ignore imposters
420 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
421 $self->stash_subs($pack . $key);
431 foreach $ar (@{$self->{'protos_todo'}}) {
432 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
433 push @ret, "sub " . $ar->[0] . "$proto;\n";
435 delete $self->{'protos_todo'};
443 while (length($opt = substr($opts, 0, 1))) {
445 $self->{'cuddle'} = " ";
446 $opts = substr($opts, 1);
447 } elsif ($opt eq "i") {
448 $opts =~ s/^i(\d+)//;
449 $self->{'indent_size'} = $1;
450 } elsif ($opt eq "T") {
451 $self->{'use_tabs'} = 1;
452 $opts = substr($opts, 1);
453 } elsif ($opt eq "v") {
454 $opts =~ s/^v([^.]*)(.|$)//;
455 $self->{'ex_const'} = $1;
462 my $self = bless {}, $class;
463 $self->{'subs_todo'} = [];
464 $self->{'files'} = {};
465 $self->{'curstash'} = "main";
466 $self->{'curcop'} = undef;
467 $self->{'cuddle'} = "\n";
468 $self->{'indent_size'} = 4;
469 $self->{'use_tabs'} = 0;
470 $self->{'expand'} = 0;
471 $self->{'unquote'} = 0;
472 $self->{'linenums'} = 0;
473 $self->{'parens'} = 0;
474 $self->{'ex_const'} = "'???'";
476 $self->{'ambient_arybase'} = 0;
477 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
478 $self->{'ambient_hints'} = 0;
481 while (my $arg = shift @_) {
482 if ($arg =~ /^-f(.*)/) {
483 $self->{'files'}{$1} = 1;
484 } elsif ($arg eq "-p") {
485 $self->{'parens'} = 1;
486 } elsif ($arg eq "-l") {
487 $self->{'linenums'} = 1;
488 } elsif ($arg eq "-q") {
489 $self->{'unquote'} = 1;
490 } elsif (substr($arg, 0, 2) eq "-s") {
491 $self->style_opts(substr $arg, 2);
492 } elsif ($arg =~ /^-x(\d)$/) {
493 $self->{'expand'} = $1;
500 # Mask out the bits that L<warnings::register> uses
503 $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
510 # Initialise the contextual information, either from
511 # defaults provided with the ambient_pragmas method,
512 # or from perl's own defaults otherwise.
516 $self->{'arybase'} = $self->{'ambient_arybase'};
517 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
518 ? $self->{'ambient_warnings'} & WARN_MASK
520 $self->{'hints'} = $self->{'ambient_hints'} & 0xFF;
522 # also a convenient place to clear out subs_declared
523 delete $self->{'subs_declared'};
529 my $self = B::Deparse->new(@args);
530 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
531 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
532 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
533 for my $block (@BEGINs, @INITs, @ENDs) {
534 $self->todo($block, 0);
537 $self->{'curcv'} = main_cv;
538 $self->{'curcvlex'} = undef;
539 print $self->print_protos;
540 @{$self->{'subs_todo'}} =
541 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
542 print $self->indent($self->deparse(main_root, 0)), "\n"
543 unless null main_root;
545 while (scalar(@{$self->{'subs_todo'}})) {
546 push @text, $self->next_todo;
548 print $self->indent(join("", @text)), "\n" if @text;
550 # Print __DATA__ section, if necessary
552 if (defined *{$self->{'curstash'}."::DATA"}{IO}) {
554 print readline(*{$self->{'curstash'}."::DATA"});
562 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
565 return $self->indent($self->deparse_sub(svref_2object($sub)));
568 sub ambient_pragmas {
570 my ($arybase, $hint_bits, $warning_bits) = (0, 0);
576 if ($name eq 'strict') {
579 if ($val eq 'none') {
580 $hint_bits &= ~strict::bits(qw/refs subs vars/);
586 @names = qw/refs subs vars/;
592 @names = split' ', $val;
594 $hint_bits |= strict::bits(@names);
597 elsif ($name eq '$[') {
601 elsif ($name eq 'integer'
603 || $name eq 'utf8') {
606 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
609 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
613 elsif ($name eq 're') {
615 if ($val eq 'none') {
616 $hint_bits &= ~re::bits(qw/taint eval/);
622 @names = qw/taint eval/;
628 @names = split' ',$val;
630 $hint_bits |= re::bits(@names);
633 elsif ($name eq 'warnings') {
634 if ($val eq 'none') {
635 $warning_bits = $warnings::NONE;
644 @names = split/\s+/, $val;
647 $warning_bits = $warnings::NONE if !defined ($warning_bits);
648 $warning_bits |= warnings::bits(@names);
651 elsif ($name eq 'warning_bits') {
652 $warning_bits = $val;
655 elsif ($name eq 'hint_bits') {
660 croak "Unknown pragma type: $name";
664 croak "The ambient_pragmas method expects an even number of args";
667 $self->{'ambient_arybase'} = $arybase;
668 $self->{'ambient_warnings'} = $warning_bits;
669 $self->{'ambient_hints'} = $hint_bits;
674 my($op, $cx, $flags) = @_;
676 Carp::confess("Null op in deparse") if !defined($op)
677 || class($op) eq "NULL";
678 my $meth = "pp_" . $op->name;
680 return $self->$meth($op, $cx, $flags);
682 return $self->$meth($op, $cx);
688 my @lines = split(/\n/, $txt);
693 my $cmd = substr($line, 0, 1);
694 if ($cmd eq "\t" or $cmd eq "\b") {
695 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
696 if ($self->{'use_tabs'}) {
697 $leader = "\t" x ($level / 8) . " " x ($level % 8);
699 $leader = " " x $level;
701 $line = substr($line, 1);
703 if (substr($line, 0, 1) eq "\f") {
704 $line = substr($line, 1); # no indent
706 $line = $leader . $line;
710 return join("\n", @lines);
717 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
718 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
719 local $self->{'curcop'} = $self->{'curcop'};
720 if ($cv->FLAGS & SVf_POK) {
721 $proto = "(". $cv->PV . ") ";
723 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
725 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
726 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
727 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
730 local($self->{'curcv'}) = $cv;
731 local($self->{'curcvlex'});
732 local(@$self{qw'curstash warnings hints'})
733 = @$self{qw'curstash warnings hints'};
735 if (not null $cv->ROOT) {
736 my $lineseq = $cv->ROOT->first;
737 if ($lineseq->name eq "lineseq") {
739 for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
742 $body = $self->lineseq(undef, @ops).";";
743 my $scope_en = $self->find_scope_en($lineseq);
744 if (defined $scope_en) {
745 my $subs = join"", $self->seq_subs($scope_en);
746 $body .= ";\n$subs" if length($subs);
750 $body = $self->deparse($cv->ROOT->first, 0);
754 my $sv = $cv->const_sv;
756 # uh-oh. inlinable sub... format it differently
757 return $proto . "{ " . const($sv) . " }\n";
758 } else { # XSUB? (or just a declaration)
762 return $proto ."{\n\t$body\n\b}" ."\n";
769 local($self->{'curcv'}) = $form;
770 local($self->{'curcvlex'});
771 local($self->{'in_format'}) = 1;
772 local(@$self{qw'curstash warnings hints'})
773 = @$self{qw'curstash warnings hints'};
774 my $op = $form->ROOT;
776 return "\f." if $op->first->name eq 'stub';
777 $op = $op->first->first; # skip leavewrite, lineseq
778 while (not null $op) {
779 $op = $op->sibling; # skip nextstate
781 $kid = $op->first->sibling; # skip pushmark
782 push @text, "\f".$self->const_sv($kid)->PV;
783 $kid = $kid->sibling;
784 for (; not null $kid; $kid = $kid->sibling) {
785 push @exprs, $self->deparse($kid, 0);
787 push @text, "\f".join(", ", @exprs)."\n" if @exprs;
790 return join("", @text) . "\f.";
795 return $op->name eq "leave" || $op->name eq "scope"
796 || $op->name eq "lineseq"
797 || ($op->name eq "null" && class($op) eq "UNOP"
798 && (is_scope($op->first) || $op->first->name eq "enter"));
802 my $name = $_[0]->name;
803 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
806 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
808 return (!null($op) and null($op->sibling)
809 and $op->name eq "null" and class($op) eq "UNOP"
810 and (($op->first->name =~ /^(and|or)$/
811 and $op->first->first->sibling->name eq "lineseq")
812 or ($op->first->name eq "lineseq"
813 and not null $op->first->first->sibling
814 and $op->first->first->sibling->name eq "unstack")
820 return ($op->name eq "rv2sv" or
821 $op->name eq "padsv" or
822 $op->name eq "gv" or # only in array/hash constructs
823 $op->flags & OPf_KIDS && !null($op->first)
824 && $op->first->name eq "gvsv");
829 my($text, $cx, $prec) = @_;
830 if ($prec < $cx # unary ops nest just fine
831 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
832 or $self->{'parens'})
835 # In a unop, let parent reuse our parens; see maybe_parens_unop
836 $text = "\cS" . $text if $cx == 16;
843 # same as above, but get around the `if it looks like a function' rule
844 sub maybe_parens_unop {
846 my($name, $kid, $cx) = @_;
847 if ($cx > 16 or $self->{'parens'}) {
848 $kid = $self->deparse($kid, 1);
849 if ($name eq "umask" && $kid =~ /^\d+$/) {
850 $kid = sprintf("%#o", $kid);
852 return "$name($kid)";
854 $kid = $self->deparse($kid, 16);
855 if ($name eq "umask" && $kid =~ /^\d+$/) {
856 $kid = sprintf("%#o", $kid);
858 if (substr($kid, 0, 1) eq "\cS") {
860 return $name . substr($kid, 1);
861 } elsif (substr($kid, 0, 1) eq "(") {
862 # avoid looks-like-a-function trap with extra parens
863 # (`+' can lead to ambiguities)
864 return "$name(" . $kid . ")";
871 sub maybe_parens_func {
873 my($func, $text, $cx, $prec) = @_;
874 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
875 return "$func($text)";
877 return "$func $text";
883 my($op, $cx, $text) = @_;
884 my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
885 if ($op->private & (OPpLVAL_INTRO|$our_intro)
886 and not $self->{'avoid_local'}{$$op}) {
887 my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
888 if (want_scalar($op)) {
889 return "$our_local $text";
891 return $self->maybe_parens_func("$our_local", $text, $cx, 16);
900 my($op, $cx, $func, @args) = @_;
901 if ($op->private & OPpTARGET_MY) {
902 my $var = $self->padname($op->targ);
903 my $val = $func->($self, $op, 7, @args);
904 return $self->maybe_parens("$var = $val", $cx, 7);
906 return $func->($self, $op, $cx, @args);
913 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
918 my($op, $cx, $text) = @_;
919 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
920 if (want_scalar($op)) {
923 return $self->maybe_parens_func("my", $text, $cx, 16);
930 # The following OPs don't have functions:
932 # pp_padany -- does not exist after parsing
933 # pp_rcatline -- does not exist
935 sub pp_enter { # see also leave
936 cluck "unexpected OP_ENTER";
940 sub pp_pushmark { # see also list
941 cluck "unexpected OP_PUSHMARK";
945 sub pp_leavesub { # see also deparse_sub
946 cluck "unexpected OP_LEAVESUB";
950 sub pp_leavewrite { # see also deparse_format
951 cluck "unexpected OP_LEAVEWRITE";
955 sub pp_method { # see also entersub
956 cluck "unexpected OP_METHOD";
960 sub pp_regcmaybe { # see also regcomp
961 cluck "unexpected OP_REGCMAYBE";
965 sub pp_regcreset { # see also regcomp
966 cluck "unexpected OP_REGCRESET";
970 sub pp_substcont { # see also subst
971 cluck "unexpected OP_SUBSTCONT";
975 sub pp_grepstart { # see also grepwhile
976 cluck "unexpected OP_GREPSTART";
980 sub pp_mapstart { # see also mapwhile
981 cluck "unexpected OP_MAPSTART";
985 sub pp_method_named {
986 cluck "unexpected OP_METHOD_NAMED";
990 sub pp_flip { # see also flop
991 cluck "unexpected OP_FLIP";
995 sub pp_iter { # see also leaveloop
996 cluck "unexpected OP_ITER";
1000 sub pp_enteriter { # see also leaveloop
1001 cluck "unexpected OP_ENTERITER";
1005 sub pp_enterloop { # see also leaveloop
1006 cluck "unexpected OP_ENTERLOOP";
1010 sub pp_leaveeval { # see also entereval
1011 cluck "unexpected OP_LEAVEEVAL";
1015 sub pp_entertry { # see also leavetry
1016 cluck "unexpected OP_ENTERTRY";
1020 # $root should be the op which represents the root of whatever
1021 # we're sequencing here. If it's undefined, then we don't append
1022 # any subroutine declarations to the deparsed ops, otherwise we
1023 # append appropriate declarations.
1025 my($self, $root, @ops) = @_;
1028 my $out_cop = $self->{'curcop'};
1029 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1031 if (defined $root) {
1032 $limit_seq = $out_seq;
1033 my $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
1034 $limit_seq = $nseq if !defined($limit_seq)
1035 or defined($nseq) && $nseq < $limit_seq;
1037 $limit_seq = $self->{'limit_seq'}
1038 if defined($self->{'limit_seq'})
1039 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1040 local $self->{'limit_seq'} = $limit_seq;
1041 for (my $i = 0; $i < @ops; $i++) {
1043 if (is_state $ops[$i]) {
1044 $expr = $self->deparse($ops[$i], 0);
1051 if (!is_state $ops[$i] and (my $ls = $ops[$i+1]) and
1052 !null($ops[$i+1]) and $ops[$i+1]->name eq "lineseq")
1054 if ($ls->first && !null($ls->first) && is_state($ls->first)
1055 && (my $sib = $ls->first->sibling)) {
1056 if (!null($sib) && $sib->name eq "leaveloop") {
1057 push @exprs, $expr . $self->for_loop($ops[$i], 0);
1063 $expr .= $self->deparse($ops[$i], 0, (@ops != 1));
1064 $expr =~ s/;\n?\z//;
1067 my $body = join(";\n", grep {length} @exprs);
1069 if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
1070 $subs = join "\n", $self->seq_subs($limit_seq);
1072 return join(";\n", grep {length} $body, $subs);
1076 my($real_block, $self, $op, $cx, $flags) = @_;
1080 local(@$self{qw'curstash warnings hints'})
1081 = @$self{qw'curstash warnings hints'} if $real_block;
1083 $kid = $op->first->sibling; # skip enter
1084 if (is_miniwhile($kid)) {
1085 my $top = $kid->first;
1086 my $name = $top->name;
1087 if ($name eq "and") {
1089 } elsif ($name eq "or") {
1091 } else { # no conditional -> while 1 or until 0
1092 return $self->deparse($top->first, 1) . " while 1";
1094 my $cond = $top->first;
1095 my $body = $cond->sibling->first; # skip lineseq
1096 $cond = $self->deparse($cond, 1);
1097 $body = $self->deparse($body, 1);
1098 return "$body $name $cond";
1103 for (; !null($kid); $kid = $kid->sibling) {
1106 if ($flags || $cx > 0) { # inside an expression, (a do {} while for lineseq)
1107 return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
1109 my $lineseq = $self->lineseq($op, @kids);
1110 return (length ($lineseq) ? "$lineseq;" : "");
1114 sub pp_scope { scopeop(0, @_); }
1115 sub pp_lineseq { scopeop(0, @_); }
1116 sub pp_leave { scopeop(1, @_); }
1118 # The BEGIN {} is used here because otherwise this code isn't executed
1119 # when you run B::Deparse on itself.
1121 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1122 "ENV", "ARGV", "ARGVOUT", "_"); }
1127 Carp::confess() if $gv->isa("B::CV");
1128 my $stash = $gv->STASH->NAME;
1129 my $name = $gv->SAFENAME;
1130 if ($stash eq $self->{'curstash'} or $globalnames{$name}
1131 or $name =~ /^[^A-Za-z_]/)
1135 $stash = $stash . "::";
1137 if ($name =~ /^\^../) {
1138 $name = "{$name}"; # ${^WARNING_BITS} etc
1140 return $stash . $name;
1143 # Return the name to use for a stash variable.
1144 # If a lexical with the same name is in scope, it may need to be
1146 sub stash_variable {
1147 my ($self, $prefix, $name) = @_;
1149 return "$prefix$name" if $name =~ /::/;
1151 unless ($prefix eq '$' || $prefix eq '@' ||
1152 $prefix eq '%' || $prefix eq '$#') {
1153 return "$prefix$name";
1156 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1157 return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
1158 return "$prefix$name";
1162 my ($self, $name) = @_;
1163 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1165 return 0 if !defined($self->{'curcop'});
1166 my $seq = $self->{'curcop'}->cop_seq;
1167 return 0 if !exists $self->{'curcvlex'}{$name};
1168 for my $a (@{$self->{'curcvlex'}{$name}}) {
1169 my ($st, $en) = @$a;
1170 return 1 if $seq > $st && $seq <= $en;
1175 sub populate_curcvlex {
1177 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1178 my @padlist = $cv->PADLIST->ARRAY;
1179 my @ns = $padlist[0]->ARRAY;
1181 for (my $i=0; $i<@ns; ++$i) {
1182 next if class($ns[$i]) eq "SPECIAL";
1183 next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars
1184 if (class($ns[$i]) eq "PV") {
1185 # Probably that pesky lexical @_
1188 my $name = $ns[$i]->PVX;
1189 my $seq_st = $ns[$i]->NVX;
1190 my $seq_en = int($ns[$i]->IVX);
1192 push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
1197 sub find_scope_st { ((find_scope(@_))[0]); }
1198 sub find_scope_en { ((find_scope(@_))[1]); }
1200 # Recurses down the tree, looking for pad variable introductions and COPs
1202 my ($self, $op, $scope_st, $scope_en) = @_;
1203 Carp::cluck() if !defined $op;
1204 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1206 for (my $o=$op->first; $$o; $o=$o->sibling) {
1207 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1208 my $s = int($self->padname_sv($o->targ)->NVX);
1209 my $e = $self->padname_sv($o->targ)->IVX;
1210 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1211 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1213 elsif (is_state($o)) {
1214 my $c = $o->cop_seq;
1215 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1216 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1218 elsif ($o->flags & OPf_KIDS) {
1219 ($scope_st, $scope_en) =
1220 $self->find_scope($o, $scope_st, $scope_en)
1224 return ($scope_st, $scope_en);
1227 # Returns a list of subs which should be inserted before the COP
1229 my ($self, $op, $out_seq) = @_;
1230 my $seq = $op->cop_seq;
1231 # If we have nephews, then our sequence number indicates
1232 # the cop_seq of the end of some sort of scope.
1233 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1234 and my $nseq = $self->find_scope_st($op->sibling) ) {
1237 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1238 return $self->seq_subs($seq);
1242 my ($self, $seq) = @_;
1244 #push @text, "# ($seq)\n";
1246 return "" if !defined $seq;
1247 while (scalar(@{$self->{'subs_todo'}})
1248 and $seq > $self->{'subs_todo'}[0][0]) {
1249 push @text, $self->next_todo;
1254 # Notice how subs and formats are inserted between statements here;
1255 # also $[ assignments and pragmas.
1259 $self->{'curcop'} = $op;
1261 push @text, $self->cop_subs($op);
1262 push @text, $op->label . ": " if $op->label;
1263 my $stash = $op->stashpv;
1264 if ($stash ne $self->{'curstash'}) {
1265 push @text, "package $stash;\n";
1266 $self->{'curstash'} = $stash;
1268 if ($self->{'linenums'}) {
1269 push @text, "\f#line " . $op->line .
1270 ' "' . $op->file, qq'"\n';
1273 if ($self->{'arybase'} != $op->arybase) {
1274 push @text, '$[ = '. $op->arybase .";\n";
1275 $self->{'arybase'} = $op->arybase;
1278 my $warnings = $op->warnings;
1280 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1281 $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
1283 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1284 $warning_bits = $warnings::NONE;
1286 elsif ($warnings->isa("B::SPECIAL")) {
1287 $warning_bits = undef;
1290 $warning_bits = $warnings->PV & WARN_MASK;
1293 if (defined ($warning_bits) and
1294 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1295 push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1296 $self->{'warnings'} = $warning_bits;
1299 if ($self->{'hints'} != $op->private) {
1300 push @text, declare_hints($self->{'hints'}, $op->private);
1301 $self->{'hints'} = $op->private;
1304 return join("", @text);
1307 sub declare_warnings {
1308 my ($from, $to) = @_;
1309 if (($to & WARN_MASK) eq warnings::bits("all")) {
1310 return "use warnings;\n";
1312 elsif (($to & WARN_MASK) eq "\0"x length($to)) {
1313 return "no warnings;\n";
1315 return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n";
1319 my ($from, $to) = @_;
1320 my $use = $to & ~$from;
1321 my $no = $from & ~$to;
1323 for my $pragma (hint_pragmas($use)) {
1324 $decls .= "use $pragma;\n";
1326 for my $pragma (hint_pragmas($no)) {
1327 $decls .= "no $pragma;\n";
1335 push @pragmas, "integer" if $bits & 0x1;
1336 push @pragmas, "strict 'refs'" if $bits & 0x2;
1337 push @pragmas, "bytes" if $bits & 0x8;
1341 sub pp_dbstate { pp_nextstate(@_) }
1342 sub pp_setstate { pp_nextstate(@_) }
1344 sub pp_unstack { return "" } # see also leaveloop
1348 my($op, $cx, $name) = @_;
1354 my($op, $cx, $name) = @_;
1362 sub pp_wantarray { baseop(@_, "wantarray") }
1363 sub pp_fork { baseop(@_, "fork") }
1364 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1365 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1366 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1367 sub pp_tms { baseop(@_, "times") }
1368 sub pp_ghostent { baseop(@_, "gethostent") }
1369 sub pp_gnetent { baseop(@_, "getnetent") }
1370 sub pp_gprotoent { baseop(@_, "getprotoent") }
1371 sub pp_gservent { baseop(@_, "getservent") }
1372 sub pp_ehostent { baseop(@_, "endhostent") }
1373 sub pp_enetent { baseop(@_, "endnetent") }
1374 sub pp_eprotoent { baseop(@_, "endprotoent") }
1375 sub pp_eservent { baseop(@_, "endservent") }
1376 sub pp_gpwent { baseop(@_, "getpwent") }
1377 sub pp_spwent { baseop(@_, "setpwent") }
1378 sub pp_epwent { baseop(@_, "endpwent") }
1379 sub pp_ggrent { baseop(@_, "getgrent") }
1380 sub pp_sgrent { baseop(@_, "setgrent") }
1381 sub pp_egrent { baseop(@_, "endgrent") }
1382 sub pp_getlogin { baseop(@_, "getlogin") }
1384 sub POSTFIX () { 1 }
1386 # I couldn't think of a good short name, but this is the category of
1387 # symbolic unary operators with interesting precedence
1391 my($op, $cx, $name, $prec, $flags) = (@_, 0);
1392 my $kid = $op->first;
1393 $kid = $self->deparse($kid, $prec);
1394 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1398 sub pp_preinc { pfixop(@_, "++", 23) }
1399 sub pp_predec { pfixop(@_, "--", 23) }
1400 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1401 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1402 sub pp_i_preinc { pfixop(@_, "++", 23) }
1403 sub pp_i_predec { pfixop(@_, "--", 23) }
1404 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1405 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1406 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1408 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1412 if ($op->first->name =~ /^(i_)?negate$/) {
1414 $self->pfixop($op, $cx, "-", 21.5);
1416 $self->pfixop($op, $cx, "-", 21);
1419 sub pp_i_negate { pp_negate(@_) }
1425 $self->pfixop($op, $cx, "not ", 4);
1427 $self->pfixop($op, $cx, "!", 21);
1433 my($op, $cx, $name) = @_;
1435 if ($op->flags & OPf_KIDS) {
1437 if (defined prototype("CORE::$name")
1438 && prototype("CORE::$name") =~ /^;?\*/
1439 && $kid->name eq "rv2gv") {
1443 return $self->maybe_parens_unop($name, $kid, $cx);
1445 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1449 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1450 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1451 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1452 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1453 sub pp_defined { unop(@_, "defined") }
1454 sub pp_undef { unop(@_, "undef") }
1455 sub pp_study { unop(@_, "study") }
1456 sub pp_ref { unop(@_, "ref") }
1457 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1459 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1460 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1461 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1462 sub pp_srand { unop(@_, "srand") }
1463 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1464 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1465 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1466 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1467 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1468 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1469 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1471 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1472 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1473 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1475 sub pp_each { unop(@_, "each") }
1476 sub pp_values { unop(@_, "values") }
1477 sub pp_keys { unop(@_, "keys") }
1478 sub pp_pop { unop(@_, "pop") }
1479 sub pp_shift { unop(@_, "shift") }
1481 sub pp_caller { unop(@_, "caller") }
1482 sub pp_reset { unop(@_, "reset") }
1483 sub pp_exit { unop(@_, "exit") }
1484 sub pp_prototype { unop(@_, "prototype") }
1486 sub pp_close { unop(@_, "close") }
1487 sub pp_fileno { unop(@_, "fileno") }
1488 sub pp_umask { unop(@_, "umask") }
1489 sub pp_untie { unop(@_, "untie") }
1490 sub pp_tied { unop(@_, "tied") }
1491 sub pp_dbmclose { unop(@_, "dbmclose") }
1492 sub pp_getc { unop(@_, "getc") }
1493 sub pp_eof { unop(@_, "eof") }
1494 sub pp_tell { unop(@_, "tell") }
1495 sub pp_getsockname { unop(@_, "getsockname") }
1496 sub pp_getpeername { unop(@_, "getpeername") }
1498 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1499 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1500 sub pp_readlink { unop(@_, "readlink") }
1501 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1502 sub pp_readdir { unop(@_, "readdir") }
1503 sub pp_telldir { unop(@_, "telldir") }
1504 sub pp_rewinddir { unop(@_, "rewinddir") }
1505 sub pp_closedir { unop(@_, "closedir") }
1506 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1507 sub pp_localtime { unop(@_, "localtime") }
1508 sub pp_gmtime { unop(@_, "gmtime") }
1509 sub pp_alarm { unop(@_, "alarm") }
1510 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1512 sub pp_dofile { unop(@_, "do") }
1513 sub pp_entereval { unop(@_, "eval") }
1515 sub pp_ghbyname { unop(@_, "gethostbyname") }
1516 sub pp_gnbyname { unop(@_, "getnetbyname") }
1517 sub pp_gpbyname { unop(@_, "getprotobyname") }
1518 sub pp_shostent { unop(@_, "sethostent") }
1519 sub pp_snetent { unop(@_, "setnetent") }
1520 sub pp_sprotoent { unop(@_, "setprotoent") }
1521 sub pp_sservent { unop(@_, "setservent") }
1522 sub pp_gpwnam { unop(@_, "getpwnam") }
1523 sub pp_gpwuid { unop(@_, "getpwuid") }
1524 sub pp_ggrnam { unop(@_, "getgrnam") }
1525 sub pp_ggrgid { unop(@_, "getgrgid") }
1527 sub pp_lock { unop(@_, "lock") }
1533 if ($op->private & OPpEXISTS_SUB) {
1534 # Checking for the existence of a subroutine
1535 return $self->maybe_parens_func("exists",
1536 $self->pp_rv2cv($op->first, 16), $cx, 16);
1538 if ($op->flags & OPf_SPECIAL) {
1539 # Array element, not hash element
1540 return $self->maybe_parens_func("exists",
1541 $self->pp_aelem($op->first, 16), $cx, 16);
1543 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1551 if ($op->private & OPpSLICE) {
1552 if ($op->flags & OPf_SPECIAL) {
1553 # Deleting from an array, not a hash
1554 return $self->maybe_parens_func("delete",
1555 $self->pp_aslice($op->first, 16),
1558 return $self->maybe_parens_func("delete",
1559 $self->pp_hslice($op->first, 16),
1562 if ($op->flags & OPf_SPECIAL) {
1563 # Deleting from an array, not a hash
1564 return $self->maybe_parens_func("delete",
1565 $self->pp_aelem($op->first, 16),
1568 return $self->maybe_parens_func("delete",
1569 $self->pp_helem($op->first, 16),
1577 if (class($op) eq "UNOP" and $op->first->name eq "const"
1578 and $op->first->private & OPpCONST_BARE)
1580 my $name = $self->const_sv($op->first)->PV;
1583 return "require $name";
1585 $self->unop($op, $cx, "require");
1592 my $kid = $op->first;
1593 if (not null $kid->sibling) {
1594 # XXX Was a here-doc
1595 return $self->dquote($op);
1597 $self->unop(@_, "scalar");
1604 #cluck "curcv was undef" unless $self->{curcv};
1605 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1611 my $kid = $op->first;
1612 if ($kid->name eq "null") {
1614 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1615 my($pre, $post) = @{{"anonlist" => ["[","]"],
1616 "anonhash" => ["{","}"]}->{$kid->name}};
1618 $kid = $kid->first->sibling; # skip pushmark
1619 for (; !null($kid); $kid = $kid->sibling) {
1620 $expr = $self->deparse($kid, 6);
1623 return $pre . join(", ", @exprs) . $post;
1624 } elsif (!null($kid->sibling) and
1625 $kid->sibling->name eq "anoncode") {
1627 $self->deparse_sub($self->padval($kid->sibling->targ));
1628 } elsif ($kid->name eq "pushmark") {
1629 my $sib_name = $kid->sibling->name;
1630 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1631 and not $kid->sibling->flags & OPf_REF)
1633 # The @a in \(@a) isn't in ref context, but only when the
1635 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1636 } elsif ($sib_name eq 'entersub') {
1637 my $text = $self->deparse($kid->sibling, 1);
1638 # Always show parens for \(&func()), but only with -p otherwise
1639 $text = "($text)" if $self->{'parens'}
1640 or $kid->sibling->private & OPpENTERSUB_AMPER;
1645 $self->pfixop($op, $cx, "\\", 20);
1648 sub pp_srefgen { pp_refgen(@_) }
1653 my $kid = $op->first;
1654 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1655 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
1656 return $self->unop($op, $cx, "readline");
1659 # Unary operators that can occur as pseudo-listops inside double quotes
1662 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1664 if ($op->flags & OPf_KIDS) {
1666 # If there's more than one kid, the first is an ex-pushmark.
1667 $kid = $kid->sibling if not null $kid->sibling;
1668 return $self->maybe_parens_unop($name, $kid, $cx);
1670 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1674 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1675 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1676 sub pp_uc { dq_unop(@_, "uc") }
1677 sub pp_lc { dq_unop(@_, "lc") }
1678 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1682 my ($op, $cx, $name) = @_;
1683 if (class($op) eq "PVOP") {
1684 return "$name " . $op->pv;
1685 } elsif (class($op) eq "OP") {
1687 } elsif (class($op) eq "UNOP") {
1688 # Note -- loop exits are actually exempt from the
1689 # looks-like-a-func rule, but a few extra parens won't hurt
1690 return $self->maybe_parens_unop($name, $op->first, $cx);
1694 sub pp_last { loopex(@_, "last") }
1695 sub pp_next { loopex(@_, "next") }
1696 sub pp_redo { loopex(@_, "redo") }
1697 sub pp_goto { loopex(@_, "goto") }
1698 sub pp_dump { loopex(@_, "dump") }
1702 my($op, $cx, $name) = @_;
1703 if (class($op) eq "UNOP") {
1704 # Genuine `-X' filetests are exempt from the LLAFR, but not
1705 # l?stat(); for the sake of clarity, give'em all parens
1706 return $self->maybe_parens_unop($name, $op->first, $cx);
1707 } elsif (class($op) eq "SVOP") {
1708 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1709 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1714 sub pp_lstat { ftst(@_, "lstat") }
1715 sub pp_stat { ftst(@_, "stat") }
1716 sub pp_ftrread { ftst(@_, "-R") }
1717 sub pp_ftrwrite { ftst(@_, "-W") }
1718 sub pp_ftrexec { ftst(@_, "-X") }
1719 sub pp_fteread { ftst(@_, "-r") }
1720 sub pp_ftewrite { ftst(@_, "-w") }
1721 sub pp_fteexec { ftst(@_, "-x") }
1722 sub pp_ftis { ftst(@_, "-e") }
1723 sub pp_fteowned { ftst(@_, "-O") }
1724 sub pp_ftrowned { ftst(@_, "-o") }
1725 sub pp_ftzero { ftst(@_, "-z") }
1726 sub pp_ftsize { ftst(@_, "-s") }
1727 sub pp_ftmtime { ftst(@_, "-M") }
1728 sub pp_ftatime { ftst(@_, "-A") }
1729 sub pp_ftctime { ftst(@_, "-C") }
1730 sub pp_ftsock { ftst(@_, "-S") }
1731 sub pp_ftchr { ftst(@_, "-c") }
1732 sub pp_ftblk { ftst(@_, "-b") }
1733 sub pp_ftfile { ftst(@_, "-f") }
1734 sub pp_ftdir { ftst(@_, "-d") }
1735 sub pp_ftpipe { ftst(@_, "-p") }
1736 sub pp_ftlink { ftst(@_, "-l") }
1737 sub pp_ftsuid { ftst(@_, "-u") }
1738 sub pp_ftsgid { ftst(@_, "-g") }
1739 sub pp_ftsvtx { ftst(@_, "-k") }
1740 sub pp_fttty { ftst(@_, "-t") }
1741 sub pp_fttext { ftst(@_, "-T") }
1742 sub pp_ftbinary { ftst(@_, "-B") }
1744 sub SWAP_CHILDREN () { 1 }
1745 sub ASSIGN () { 2 } # has OP= variant
1746 sub LIST_CONTEXT () { 4 } # Assignment is in list context
1752 my $name = $op->name;
1753 if ($name eq "concat" and $op->first->name eq "concat") {
1754 # avoid spurious `=' -- see comment in pp_concat
1757 if ($name eq "null" and class($op) eq "UNOP"
1758 and $op->first->name =~ /^(and|x?or)$/
1759 and null $op->first->sibling)
1761 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1762 # with a null that's used as the common end point of the two
1763 # flows of control. For precedence purposes, ignore it.
1764 # (COND_EXPRs have these too, but we don't bother with
1765 # their associativity).
1766 return assoc_class($op->first);
1768 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1771 # Left associative operators, like `+', for which
1772 # $a + $b + $c is equivalent to ($a + $b) + $c
1775 %left = ('multiply' => 19, 'i_multiply' => 19,
1776 'divide' => 19, 'i_divide' => 19,
1777 'modulo' => 19, 'i_modulo' => 19,
1779 'add' => 18, 'i_add' => 18,
1780 'subtract' => 18, 'i_subtract' => 18,
1782 'left_shift' => 17, 'right_shift' => 17,
1784 'bit_or' => 12, 'bit_xor' => 12,
1786 'or' => 2, 'xor' => 2,
1790 sub deparse_binop_left {
1792 my($op, $left, $prec) = @_;
1793 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1794 and $left{assoc_class($op)} == $left{assoc_class($left)})
1796 return $self->deparse($left, $prec - .00001);
1798 return $self->deparse($left, $prec);
1802 # Right associative operators, like `=', for which
1803 # $a = $b = $c is equivalent to $a = ($b = $c)
1806 %right = ('pow' => 22,
1807 'sassign=' => 7, 'aassign=' => 7,
1808 'multiply=' => 7, 'i_multiply=' => 7,
1809 'divide=' => 7, 'i_divide=' => 7,
1810 'modulo=' => 7, 'i_modulo=' => 7,
1812 'add=' => 7, 'i_add=' => 7,
1813 'subtract=' => 7, 'i_subtract=' => 7,
1815 'left_shift=' => 7, 'right_shift=' => 7,
1817 'bit_or=' => 7, 'bit_xor=' => 7,
1823 sub deparse_binop_right {
1825 my($op, $right, $prec) = @_;
1826 if ($right{assoc_class($op)} && $right{assoc_class($right)}
1827 and $right{assoc_class($op)} == $right{assoc_class($right)})
1829 return $self->deparse($right, $prec - .00001);
1831 return $self->deparse($right, $prec);
1837 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1838 my $left = $op->first;
1839 my $right = $op->last;
1841 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1845 if ($flags & SWAP_CHILDREN) {
1846 ($left, $right) = ($right, $left);
1848 $left = $self->deparse_binop_left($op, $left, $prec);
1849 $left = "($left)" if $flags & LIST_CONTEXT
1850 && $left !~ /^(my|our|local|)[\@\(]/;
1851 $right = $self->deparse_binop_right($op, $right, $prec);
1852 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1855 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1856 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1857 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1858 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1859 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1860 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1861 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1862 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1863 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1864 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1865 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1867 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1868 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1869 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1870 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1871 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1873 sub pp_eq { binop(@_, "==", 14) }
1874 sub pp_ne { binop(@_, "!=", 14) }
1875 sub pp_lt { binop(@_, "<", 15) }
1876 sub pp_gt { binop(@_, ">", 15) }
1877 sub pp_ge { binop(@_, ">=", 15) }
1878 sub pp_le { binop(@_, "<=", 15) }
1879 sub pp_ncmp { binop(@_, "<=>", 14) }
1880 sub pp_i_eq { binop(@_, "==", 14) }
1881 sub pp_i_ne { binop(@_, "!=", 14) }
1882 sub pp_i_lt { binop(@_, "<", 15) }
1883 sub pp_i_gt { binop(@_, ">", 15) }
1884 sub pp_i_ge { binop(@_, ">=", 15) }
1885 sub pp_i_le { binop(@_, "<=", 15) }
1886 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1888 sub pp_seq { binop(@_, "eq", 14) }
1889 sub pp_sne { binop(@_, "ne", 14) }
1890 sub pp_slt { binop(@_, "lt", 15) }
1891 sub pp_sgt { binop(@_, "gt", 15) }
1892 sub pp_sge { binop(@_, "ge", 15) }
1893 sub pp_sle { binop(@_, "le", 15) }
1894 sub pp_scmp { binop(@_, "cmp", 14) }
1896 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1897 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
1899 # `.' is special because concats-of-concats are optimized to save copying
1900 # by making all but the first concat stacked. The effect is as if the
1901 # programmer had written `($a . $b) .= $c', except legal.
1902 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1906 my $left = $op->first;
1907 my $right = $op->last;
1910 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1914 $left = $self->deparse_binop_left($op, $left, $prec);
1915 $right = $self->deparse_binop_right($op, $right, $prec);
1916 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1919 # `x' is weird when the left arg is a list
1923 my $left = $op->first;
1924 my $right = $op->last;
1927 if ($op->flags & OPf_STACKED) {
1931 if (null($right)) { # list repeat; count is inside left-side ex-list
1932 my $kid = $left->first->sibling; # skip pushmark
1934 for (; !null($kid->sibling); $kid = $kid->sibling) {
1935 push @exprs, $self->deparse($kid, 6);
1938 $left = "(" . join(", ", @exprs). ")";
1940 $left = $self->deparse_binop_left($op, $left, $prec);
1942 $right = $self->deparse_binop_right($op, $right, $prec);
1943 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1948 my ($op, $cx, $type) = @_;
1949 my $left = $op->first;
1950 my $right = $left->sibling;
1951 $left = $self->deparse($left, 9);
1952 $right = $self->deparse($right, 9);
1953 return $self->maybe_parens("$left $type $right", $cx, 9);
1959 my $flip = $op->first;
1960 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1961 return $self->range($flip->first, $cx, $type);
1964 # one-line while/until is handled in pp_leave
1968 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1969 my $left = $op->first;
1970 my $right = $op->first->sibling;
1971 if ($cx == 0 and is_scope($right) and $blockname
1972 and $self->{'expand'} < 7)
1974 $left = $self->deparse($left, 1);
1975 $right = $self->deparse($right, 0);
1976 return "$blockname ($left) {\n\t$right\n\b}\cK";
1977 } elsif ($cx == 0 and $blockname and not $self->{'parens'}
1978 and $self->{'expand'} < 7) { # $b if $a
1979 $right = $self->deparse($right, 1);
1980 $left = $self->deparse($left, 1);
1981 return "$right $blockname $left";
1982 } elsif ($cx > $lowprec and $highop) { # $a && $b
1983 $left = $self->deparse_binop_left($op, $left, $highprec);
1984 $right = $self->deparse_binop_right($op, $right, $highprec);
1985 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1986 } else { # $a and $b
1987 $left = $self->deparse_binop_left($op, $left, $lowprec);
1988 $right = $self->deparse_binop_right($op, $right, $lowprec);
1989 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1993 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1994 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1996 # xor is syntactically a logop, but it's really a binop (contrary to
1997 # old versions of opcode.pl). Syntax is what matters here.
1998 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
2002 my ($op, $cx, $opname) = @_;
2003 my $left = $op->first;
2004 my $right = $op->first->sibling->first; # skip sassign
2005 $left = $self->deparse($left, 7);
2006 $right = $self->deparse($right, 7);
2007 return $self->maybe_parens("$left $opname $right", $cx, 7);
2010 sub pp_andassign { logassignop(@_, "&&=") }
2011 sub pp_orassign { logassignop(@_, "||=") }
2015 my($op, $cx, $name) = @_;
2017 my $parens = ($cx >= 5) || $self->{'parens'};
2018 my $kid = $op->first->sibling;
2019 return $name if null $kid;
2021 if (defined prototype("CORE::$name")
2022 && prototype("CORE::$name") =~ /^;?\*/
2023 && $kid->name eq "rv2gv") {
2024 $first = $self->deparse($kid->first, 6);
2027 $first = $self->deparse($kid, 6);
2029 if ($name eq "chmod" && $first =~ /^\d+$/) {
2030 $first = sprintf("%#o", $first);
2032 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
2033 push @exprs, $first;
2034 $kid = $kid->sibling;
2035 for (; !null($kid); $kid = $kid->sibling) {
2036 push @exprs, $self->deparse($kid, 6);
2039 return "$name(" . join(", ", @exprs) . ")";
2041 return "$name " . join(", ", @exprs);
2045 sub pp_bless { listop(@_, "bless") }
2046 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
2047 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
2048 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
2049 sub pp_index { maybe_targmy(@_, \&listop, "index") }
2050 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
2051 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
2052 sub pp_formline { listop(@_, "formline") } # see also deparse_format
2053 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
2054 sub pp_unpack { listop(@_, "unpack") }
2055 sub pp_pack { listop(@_, "pack") }
2056 sub pp_join { maybe_targmy(@_, \&listop, "join") }
2057 sub pp_splice { listop(@_, "splice") }
2058 sub pp_push { maybe_targmy(@_, \&listop, "push") }
2059 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
2060 sub pp_reverse { listop(@_, "reverse") }
2061 sub pp_warn { listop(@_, "warn") }
2062 sub pp_die { listop(@_, "die") }
2063 # Actually, return is exempt from the LLAFR (see examples in this very
2064 # module!), but for consistency's sake, ignore that fact
2065 sub pp_return { listop(@_, "return") }
2066 sub pp_open { listop(@_, "open") }
2067 sub pp_pipe_op { listop(@_, "pipe") }
2068 sub pp_tie { listop(@_, "tie") }
2069 sub pp_binmode { listop(@_, "binmode") }
2070 sub pp_dbmopen { listop(@_, "dbmopen") }
2071 sub pp_sselect { listop(@_, "select") }
2072 sub pp_select { listop(@_, "select") }
2073 sub pp_read { listop(@_, "read") }
2074 sub pp_sysopen { listop(@_, "sysopen") }
2075 sub pp_sysseek { listop(@_, "sysseek") }
2076 sub pp_sysread { listop(@_, "sysread") }
2077 sub pp_syswrite { listop(@_, "syswrite") }
2078 sub pp_send { listop(@_, "send") }
2079 sub pp_recv { listop(@_, "recv") }
2080 sub pp_seek { listop(@_, "seek") }
2081 sub pp_fcntl { listop(@_, "fcntl") }
2082 sub pp_ioctl { listop(@_, "ioctl") }
2083 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
2084 sub pp_socket { listop(@_, "socket") }
2085 sub pp_sockpair { listop(@_, "sockpair") }
2086 sub pp_bind { listop(@_, "bind") }
2087 sub pp_connect { listop(@_, "connect") }
2088 sub pp_listen { listop(@_, "listen") }
2089 sub pp_accept { listop(@_, "accept") }
2090 sub pp_shutdown { listop(@_, "shutdown") }
2091 sub pp_gsockopt { listop(@_, "getsockopt") }
2092 sub pp_ssockopt { listop(@_, "setsockopt") }
2093 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
2094 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
2095 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
2096 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
2097 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
2098 sub pp_link { maybe_targmy(@_, \&listop, "link") }
2099 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
2100 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
2101 sub pp_open_dir { listop(@_, "opendir") }
2102 sub pp_seekdir { listop(@_, "seekdir") }
2103 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
2104 sub pp_system { maybe_targmy(@_, \&listop, "system") }
2105 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
2106 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
2107 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
2108 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
2109 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
2110 sub pp_shmget { listop(@_, "shmget") }
2111 sub pp_shmctl { listop(@_, "shmctl") }
2112 sub pp_shmread { listop(@_, "shmread") }
2113 sub pp_shmwrite { listop(@_, "shmwrite") }
2114 sub pp_msgget { listop(@_, "msgget") }
2115 sub pp_msgctl { listop(@_, "msgctl") }
2116 sub pp_msgsnd { listop(@_, "msgsnd") }
2117 sub pp_msgrcv { listop(@_, "msgrcv") }
2118 sub pp_semget { listop(@_, "semget") }
2119 sub pp_semctl { listop(@_, "semctl") }
2120 sub pp_semop { listop(@_, "semop") }
2121 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
2122 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
2123 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
2124 sub pp_gsbyname { listop(@_, "getservbyname") }
2125 sub pp_gsbyport { listop(@_, "getservbyport") }
2126 sub pp_syscall { listop(@_, "syscall") }
2131 my $text = $self->dq($op->first->sibling); # skip pushmark
2132 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
2133 or $text =~ /[<>]/) {
2134 return 'glob(' . single_delim('qq', '"', $text) . ')';
2136 return '<' . $text . '>';
2140 # Truncate is special because OPf_SPECIAL makes a bareword first arg
2141 # be a filehandle. This could probably be better fixed in the core
2142 # by moving the GV lookup into ck_truc.
2148 my $parens = ($cx >= 5) || $self->{'parens'};
2149 my $kid = $op->first->sibling;
2151 if ($op->flags & OPf_SPECIAL) {
2152 # $kid is an OP_CONST
2153 $fh = $self->const_sv($kid)->PV;
2155 $fh = $self->deparse($kid, 6);
2156 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
2158 my $len = $self->deparse($kid->sibling, 6);
2160 return "truncate($fh, $len)";
2162 return "truncate $fh, $len";
2168 my($op, $cx, $name) = @_;
2170 my $kid = $op->first->sibling;
2172 if ($op->flags & OPf_STACKED) {
2174 $indir = $indir->first; # skip rv2gv
2175 if (is_scope($indir)) {
2176 $indir = "{" . $self->deparse($indir, 0) . "}";
2177 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
2178 $indir = $self->const_sv($indir)->PV;
2180 $indir = $self->deparse($indir, 24);
2182 $indir = $indir . " ";
2183 $kid = $kid->sibling;
2185 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
2186 $indir = ($op->private & OPpSORT_REVERSE) ? '{$b <=> $a} '
2189 elsif ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
2190 $indir = '{$b cmp $a} ';
2192 for (; !null($kid); $kid = $kid->sibling) {
2193 $expr = $self->deparse($kid, 6);
2196 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
2200 sub pp_prtf { indirop(@_, "printf") }
2201 sub pp_print { indirop(@_, "print") }
2202 sub pp_sort { indirop(@_, "sort") }
2206 my($op, $cx, $name) = @_;
2208 my $kid = $op->first; # this is the (map|grep)start
2209 $kid = $kid->first->sibling; # skip a pushmark
2210 my $code = $kid->first; # skip a null
2211 if (is_scope $code) {
2212 $code = "{" . $self->deparse($code, 0) . "} ";
2214 $code = $self->deparse($code, 24) . ", ";
2216 $kid = $kid->sibling;
2217 for (; !null($kid); $kid = $kid->sibling) {
2218 $expr = $self->deparse($kid, 6);
2219 push @exprs, $expr if $expr;
2221 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2224 sub pp_mapwhile { mapop(@_, "map") }
2225 sub pp_grepwhile { mapop(@_, "grep") }
2231 my $kid = $op->first->sibling; # skip pushmark
2233 my $local = "either"; # could be local(...), my(...) or our(...)
2234 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2235 # This assumes that no other private flags equal 128, and that
2236 # OPs that store things other than flags in their op_private,
2237 # like OP_AELEMFAST, won't be immediate children of a list.
2239 # OP_ENTERSUB can break this logic, so check for it.
2240 # I suspect that open and exit can too.
2242 if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
2243 or $lop->name eq "undef")
2244 or $lop->name eq "entersub"
2245 or $lop->name eq "exit"
2246 or $lop->name eq "open")
2248 $local = ""; # or not
2251 if ($lop->name =~ /^pad[ash]v$/) { # my()
2252 ($local = "", last) if $local eq "local" || $local eq "our";
2254 } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
2255 && $lop->private & OPpOUR_INTRO
2256 or $lop->name eq "null" && $lop->first->name eq "gvsv"
2257 && $lop->first->private & OPpOUR_INTRO) { # our()
2258 ($local = "", last) if $local eq "my" || $local eq "local";
2260 } elsif ($lop->name ne "undef") { # local()
2261 ($local = "", last) if $local eq "my" || $local eq "our";
2265 $local = "" if $local eq "either"; # no point if it's all undefs
2266 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2267 for (; !null($kid); $kid = $kid->sibling) {
2269 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2274 $self->{'avoid_local'}{$$lop}++;
2275 $expr = $self->deparse($kid, 6);
2276 delete $self->{'avoid_local'}{$$lop};
2278 $expr = $self->deparse($kid, 6);
2283 return "$local(" . join(", ", @exprs) . ")";
2285 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2289 sub is_ifelse_cont {
2291 return ($op->name eq "null" and class($op) eq "UNOP"
2292 and $op->first->name =~ /^(and|cond_expr)$/
2293 and is_scope($op->first->first->sibling));
2299 my $cond = $op->first;
2300 my $true = $cond->sibling;
2301 my $false = $true->sibling;
2302 my $cuddle = $self->{'cuddle'};
2303 unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
2304 (is_scope($false) || is_ifelse_cont($false))
2305 and $self->{'expand'} < 7) {
2306 $cond = $self->deparse($cond, 8);
2307 $true = $self->deparse($true, 8);
2308 $false = $self->deparse($false, 8);
2309 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2312 $cond = $self->deparse($cond, 1);
2313 $true = $self->deparse($true, 0);
2314 my $head = "if ($cond) {\n\t$true\n\b}";
2316 while (!null($false) and is_ifelse_cont($false)) {
2317 my $newop = $false->first;
2318 my $newcond = $newop->first;
2319 my $newtrue = $newcond->sibling;
2320 $false = $newtrue->sibling; # last in chain is OP_AND => no else
2321 $newcond = $self->deparse($newcond, 1);
2322 $newtrue = $self->deparse($newtrue, 0);
2323 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2325 if (!null($false)) {
2326 $false = $cuddle . "else {\n\t" .
2327 $self->deparse($false, 0) . "\n\b}\cK";
2331 return $head . join($cuddle, "", @elsifs) . $false;
2336 my($op, $cx, $init) = @_;
2337 my $enter = $op->first;
2338 my $kid = $enter->sibling;
2339 local(@$self{qw'curstash warnings hints'})
2340 = @$self{qw'curstash warnings hints'};
2345 if ($kid->name eq "lineseq") { # bare or infinite loop
2346 if (is_state $kid->last) { # infinite
2347 $head = "while (1) "; # Can't use for(;;) if there's a continue
2353 } elsif ($enter->name eq "enteriter") { # foreach
2354 my $ary = $enter->first->sibling; # first was pushmark
2355 my $var = $ary->sibling;
2356 if ($enter->flags & OPf_STACKED
2357 and not null $ary->first->sibling->sibling)
2359 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2360 $self->deparse($ary->first->sibling->sibling, 9);
2362 $ary = $self->deparse($ary, 1);
2365 if ($enter->flags & OPf_SPECIAL) { # thread special var
2366 $var = $self->pp_threadsv($enter, 1);
2367 } else { # regular my() variable
2368 $var = $self->pp_padsv($enter, 1);
2369 if ($self->padname_sv($enter->targ)->IVX ==
2370 $kid->first->first->sibling->last->cop_seq)
2372 # If the scope of this variable closes at the last
2373 # statement of the loop, it must have been
2375 $var = "my " . $var;
2378 } elsif ($var->name eq "rv2gv") {
2379 $var = $self->pp_rv2sv($var, 1);
2380 } elsif ($var->name eq "gv") {
2381 $var = "\$" . $self->deparse($var, 1);
2383 $head = "foreach $var ($ary) ";
2384 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2385 } elsif ($kid->name eq "null") { # while/until
2387 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2388 $cond = $self->deparse($kid->first, 1);
2389 $head = "$name ($cond) ";
2390 $body = $kid->first->sibling;
2391 } elsif ($kid->name eq "stub") { # bare and empty
2392 return "{;}"; # {} could be a hashref
2394 # If there isn't a continue block, then the next pointer for the loop
2395 # will point to the unstack, which is kid's penultimate child, except
2396 # in a bare loop, when it will point to the leaveloop. When neither of
2397 # these conditions hold, then the third-to-last child in the continue
2398 # block (or the last in a bare loop).
2399 my $cont_start = $enter->nextop;
2401 if ($$cont_start != $$op && ${$cont_start->sibling} != ${$body->last}) {
2403 $cont = $body->last;
2405 $cont = $body->first;
2406 while (!null($cont->sibling->sibling->sibling)) {
2407 $cont = $cont->sibling;
2410 my $state = $body->first;
2411 my $cuddle = $self->{'cuddle'};
2413 for (; $$state != $$cont; $state = $state->sibling) {
2414 push @states, $state;
2416 $body = $self->lineseq(undef, @states);
2417 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2418 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2421 $cont = $cuddle . "continue {\n\t" .
2422 $self->deparse($cont, 0) . "\n\b}\cK";
2425 return "" if !defined $body;
2427 $head = "for ($init; $cond;) ";
2430 $body = $self->deparse($body, 0);
2432 $body =~ s/;?$/;\n/;
2434 return $head . "{\n\t" . $body . "\b}" . $cont;
2437 sub pp_leaveloop { loop_common(@_, "") }
2442 my $init = $self->deparse($op, 1);
2443 return $self->loop_common($op->sibling->first->sibling, $cx, $init);
2448 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2451 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2452 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2453 BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
2454 BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
2459 if (class($op) eq "OP") {
2461 return $self->{'ex_const'} if $op->targ == OP_CONST;
2462 } elsif ($op->first->name eq "pushmark") {
2463 return $self->pp_list($op, $cx);
2464 } elsif ($op->first->name eq "enter") {
2465 return $self->pp_leave($op, $cx);
2466 } elsif ($op->targ == OP_STRINGIFY) {
2467 return $self->dquote($op, $cx);
2468 } elsif (!null($op->first->sibling) and
2469 $op->first->sibling->name eq "readline" and
2470 $op->first->sibling->flags & OPf_STACKED) {
2471 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2472 . $self->deparse($op->first->sibling, 7),
2474 } elsif (!null($op->first->sibling) and
2475 $op->first->sibling->name eq "trans" and
2476 $op->first->sibling->flags & OPf_STACKED) {
2477 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2478 . $self->deparse($op->first->sibling, 20),
2480 } elsif ($op->flags & OPf_SPECIAL && $cx == 0 && !$op->targ) {
2481 return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
2483 return $self->deparse($op->first, $cx);
2490 return $self->padname_sv($targ)->PVX;
2496 return substr($self->padname($op->targ), 1); # skip $/@/%
2502 return $self->maybe_my($op, $cx, $self->padname($op->targ));
2505 sub pp_padav { pp_padsv(@_) }
2506 sub pp_padhv { pp_padsv(@_) }
2511 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2512 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2513 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2520 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
2526 if (class($op) eq "PADOP") {
2527 return $self->padval($op->padix);
2528 } else { # class($op) eq "SVOP"
2536 my $gv = $self->gv_or_padgv($op);
2537 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2538 $self->gv_name($gv)));
2544 my $gv = $self->gv_or_padgv($op);
2545 return $self->gv_name($gv);
2551 my $gv = $self->gv_or_padgv($op);
2552 my $name = $self->gv_name($gv);
2553 $name = $self->{'curstash'}."::$name"
2554 if $name !~ /::/ && $self->lex_in_scope('@'.$name);
2556 return "\$" . $name . "[" .
2557 ($op->private + $self->{'arybase'}) . "]";
2562 my($op, $cx, $type) = @_;
2564 if (class($op) eq 'NULL' || !$op->can("first")) {
2565 Carp::cluck("Unexpected op in pp_rv2x");
2568 my $kid = $op->first;
2569 my $str = $self->deparse($kid, 0);
2570 return $self->stash_variable($type, $str) if is_scalar($kid);
2571 return $type ."{$str}";
2574 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2575 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2576 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2582 if ($op->first->name eq "padav") {
2583 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2585 return $self->maybe_local($op, $cx,
2586 $self->rv2x($op->first, $cx, '$#'));
2590 # skip down to the old, ex-rv2cv
2592 my ($self, $op, $cx) = @_;
2593 if (!null($op->first) && $op->first->name eq 'null' &&
2594 $op->first->targ eq OP_LIST)
2596 return $self->rv2x($op->first->first->sibling, $cx, "&")
2599 return $self->rv2x($op, $cx, "")
2606 my $kid = $op->first;
2607 if ($kid->name eq "const") { # constant list
2608 my $av = $self->const_sv($kid);
2609 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2611 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2615 sub is_subscriptable {
2617 if ($op->name =~ /^[ahg]elem/) {
2619 } elsif ($op->name eq "entersub") {
2620 my $kid = $op->first;
2621 return 0 unless null $kid->sibling;
2623 $kid = $kid->sibling until null $kid->sibling;
2624 return 0 if is_scope($kid);
2626 return 0 if $kid->name eq "gv";
2627 return 0 if is_scalar($kid);
2628 return is_subscriptable($kid);
2636 my ($op, $cx, $left, $right, $padname) = @_;
2637 my($array, $idx) = ($op->first, $op->first->sibling);
2638 unless ($array->name eq $padname) { # Maybe this has been fixed
2639 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2641 if ($array->name eq $padname) {
2642 $array = $self->padany($array);
2643 } elsif (is_scope($array)) { # ${expr}[0]
2644 $array = "{" . $self->deparse($array, 0) . "}";
2645 } elsif ($array->name eq "gv") {
2646 $array = $self->gv_name($self->gv_or_padgv($array));
2647 if ($array !~ /::/) {
2648 my $prefix = ($left eq '[' ? '@' : '%');
2649 $array = $self->{curstash}.'::'.$array
2650 if $self->lex_in_scope($prefix . $array);
2652 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2653 $array = $self->deparse($array, 24);
2655 # $x[20][3]{hi} or expr->[20]
2656 my $arrow = is_subscriptable($array) ? "" : "->";
2657 return $self->deparse($array, 24) . $arrow .
2658 $left . $self->deparse($idx, 1) . $right;
2660 $idx = $self->deparse($idx, 1);
2662 # Outer parens in an array index will confuse perl
2663 # if we're interpolating in a regular expression, i.e.
2664 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2666 # If $self->{parens}, then an initial '(' will
2667 # definitely be paired with a final ')'. If
2668 # !$self->{parens}, the misleading parens won't
2669 # have been added in the first place.
2671 # [You might think that we could get "(...)...(...)"
2672 # where the initial and final parens do not match
2673 # each other. But we can't, because the above would
2674 # only happen if there's an infix binop between the
2675 # two pairs of parens, and *that* means that the whole
2676 # expression would be parenthesized as well.]
2678 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2680 # Hash-element braces will autoquote a bareword inside themselves.
2681 # We need to make sure that C<$hash{warn()}> doesn't come out as
2682 # C<$hash{warn}>, which has a quite different meaning. Currently
2683 # B::Deparse will always quote strings, even if the string was a
2684 # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
2685 # for constant strings.) So we can cheat slightly here - if we see
2686 # a bareword, we know that it is supposed to be a function call.
2688 $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
2690 return "\$" . $array . $left . $idx . $right;
2693 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2694 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2699 my($glob, $part) = ($op->first, $op->last);
2700 $glob = $glob->first; # skip rv2gv
2701 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2702 my $scope = is_scope($glob);
2703 $glob = $self->deparse($glob, 0);
2704 $part = $self->deparse($part, 1);
2705 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2710 my ($op, $cx, $left, $right, $regname, $padname) = @_;
2712 my(@elems, $kid, $array, $list);
2713 if (class($op) eq "LISTOP") {
2715 } else { # ex-hslice inside delete()
2716 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2720 $array = $array->first
2721 if $array->name eq $regname or $array->name eq "null";
2722 if (is_scope($array)) {
2723 $array = "{" . $self->deparse($array, 0) . "}";
2724 } elsif ($array->name eq $padname) {
2725 $array = $self->padany($array);
2727 $array = $self->deparse($array, 24);
2729 $kid = $op->first->sibling; # skip pushmark
2730 if ($kid->name eq "list") {
2731 $kid = $kid->first->sibling; # skip list, pushmark
2732 for (; !null $kid; $kid = $kid->sibling) {
2733 push @elems, $self->deparse($kid, 6);
2735 $list = join(", ", @elems);
2737 $list = $self->deparse($kid, 1);
2739 return "\@" . $array . $left . $list . $right;
2742 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2743 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2748 my $idx = $op->first;
2749 my $list = $op->last;
2751 $list = $self->deparse($list, 1);
2752 $idx = $self->deparse($idx, 1);
2753 return "($list)" . "[$idx]";
2758 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2763 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2769 my $kid = $op->first->sibling; # skip pushmark
2770 my($meth, $obj, @exprs);
2771 if ($kid->name eq "list" and want_list $kid) {
2772 # When an indirect object isn't a bareword but the args are in
2773 # parens, the parens aren't part of the method syntax (the LLAFR
2774 # doesn't apply), but they make a list with OPf_PARENS set that
2775 # doesn't get flattened by the append_elem that adds the method,
2776 # making a (object, arg1, arg2, ...) list where the object
2777 # usually is. This can be distinguished from
2778 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2779 # object) because in the later the list is in scalar context
2780 # as the left side of -> always is, while in the former
2781 # the list is in list context as method arguments always are.
2782 # (Good thing there aren't method prototypes!)
2783 $meth = $kid->sibling;
2784 $kid = $kid->first->sibling; # skip pushmark
2786 $kid = $kid->sibling;
2787 for (; not null $kid; $kid = $kid->sibling) {
2788 push @exprs, $self->deparse($kid, 6);
2792 $kid = $kid->sibling;
2793 for (; !null ($kid->sibling) && $kid->name ne "method_named";
2794 $kid = $kid->sibling) {
2795 push @exprs, $self->deparse($kid, 6);
2799 $obj = $self->deparse($obj, 24);
2800 if ($meth->name eq "method_named") {
2801 $meth = $self->const_sv($meth)->PV;
2803 $meth = $meth->first;
2804 if ($meth->name eq "const") {
2805 # As of 5.005_58, this case is probably obsoleted by the
2806 # method_named case above
2807 $meth = $self->const_sv($meth)->PV; # needs to be bare
2809 $meth = $self->deparse($meth, 1);
2812 my $args = join(", ", @exprs);
2813 $kid = $obj . "->" . $meth;
2815 return $kid . "(" . $args . ")"; # parens mandatory
2821 # returns "&" if the prototype doesn't match the args,
2822 # or ("", $args_after_prototype_demunging) if it does.
2825 my($proto, @args) = @_;
2829 # An unbackslashed @ or % gobbles up the rest of the args
2830 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2832 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2835 return "&" if @args;
2836 } elsif ($chr eq ";") {
2838 } elsif ($chr eq "@" or $chr eq "%") {
2839 push @reals, map($self->deparse($_, 6), @args);
2845 if (want_scalar $arg) {
2846 push @reals, $self->deparse($arg, 6);
2850 } elsif ($chr eq "&") {
2851 if ($arg->name =~ /^(s?refgen|undef)$/) {
2852 push @reals, $self->deparse($arg, 6);
2856 } elsif ($chr eq "*") {
2857 if ($arg->name =~ /^s?refgen$/
2858 and $arg->first->first->name eq "rv2gv")
2860 $real = $arg->first->first; # skip refgen, null
2861 if ($real->first->name eq "gv") {
2862 push @reals, $self->deparse($real, 6);
2864 push @reals, $self->deparse($real->first, 6);
2869 } elsif (substr($chr, 0, 1) eq "\\") {
2870 $chr = substr($chr, 1);
2871 if ($arg->name =~ /^s?refgen$/ and
2872 !null($real = $arg->first) and
2873 ($chr eq "\$" && is_scalar($real->first)
2875 && $real->first->sibling->name
2878 && $real->first->sibling->name
2880 #or ($chr eq "&" # This doesn't work
2881 # && $real->first->name eq "rv2cv")
2883 && $real->first->name eq "rv2gv")))
2885 push @reals, $self->deparse($real, 6);
2892 return "&" if $proto and !$doneok; # too few args and no `;'
2893 return "&" if @args; # too many args
2894 return ("", join ", ", @reals);
2900 return $self->method($op, $cx) unless null $op->first->sibling;
2904 if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
2906 } elsif ($op->private & OPpENTERSUB_AMPER) {
2910 $kid = $kid->first->sibling; # skip ex-list, pushmark
2911 for (; not null $kid->sibling; $kid = $kid->sibling) {
2916 if (is_scope($kid)) {
2918 $kid = "{" . $self->deparse($kid, 0) . "}";
2919 } elsif ($kid->first->name eq "gv") {
2920 my $gv = $self->gv_or_padgv($kid->first);
2921 if (class($gv->CV) ne "SPECIAL") {
2922 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2924 $simple = 1; # only calls of named functions can be prototyped
2925 $kid = $self->deparse($kid, 24);
2926 } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
2928 $kid = $self->deparse($kid, 24);
2931 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2932 $kid = $self->deparse($kid, 24) . $arrow;
2935 # Doesn't matter how many prototypes there are, if
2936 # they haven't happened yet!
2937 my $declared = exists $self->{'subs_declared'}{$kid};
2938 if (!$declared && defined($proto)) {
2939 # Avoid "too early to check prototype" warning
2940 ($amper, $proto) = ('&');
2944 if ($declared and defined $proto and not $amper) {
2945 ($amper, $args) = $self->check_proto($proto, @exprs);
2946 if ($amper eq "&") {
2947 $args = join(", ", map($self->deparse($_, 6), @exprs));
2950 $args = join(", ", map($self->deparse($_, 6), @exprs));
2952 if ($prefix or $amper) {
2953 if ($op->flags & OPf_STACKED) {
2954 return $prefix . $amper . $kid . "(" . $args . ")";
2956 return $prefix . $amper. $kid;
2959 # glob() invocations can be translated into calls of
2960 # CORE::GLOBAL::glob with an second parameter, a number.
2962 if ($kid eq "CORE::GLOBAL::glob") {
2964 $args =~ s/\s*,[^,]+$//;
2967 # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
2968 # so it must have been translated from a keyword call. Translate
2970 $kid =~ s/^CORE::GLOBAL:://;
2973 return "$kid(" . $args . ")";
2974 } elsif (defined $proto and $proto eq "") {
2976 } elsif (defined $proto and $proto eq "\$" and is_scalar($exprs[0])) {
2977 return $self->maybe_parens_func($kid, $args, $cx, 16);
2978 } elsif (defined($proto) && $proto or $simple) {
2979 return $self->maybe_parens_func($kid, $args, $cx, 5);
2981 return "$kid(" . $args . ")";
2986 sub pp_enterwrite { unop(@_, "write") }
2988 # escape things that cause interpolation in double quotes,
2989 # but not character escapes
2992 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
3000 # Matches any string which is balanced with respect to {braces}
3011 # the same, but treat $|, $), $( and $ at the end of the string differently
3025 (\(\?\??\{$bal\}\)) # $4
3031 /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3036 # This is for regular expressions with the /x modifier
3037 # We have to leave comments unmangled.
3038 sub re_uninterp_extended {
3051 ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
3052 | \#[^\n]* # (skip over comments)
3059 /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3065 # character escapes, but not delimiters that might need to be escaped
3066 sub escape_str { # ASCII, UTF8
3068 $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3070 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
3076 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
3077 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
3081 # For regexes with the /x modifier.
3082 # Leave whitespace unmangled.
3083 sub escape_extended_re {
3085 $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3086 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
3087 $str =~ s/\n/\n\f/g;
3091 # Don't do this for regexen
3094 $str =~ s/\\/\\\\/g;
3098 # Remove backslashes which precede literal control characters,
3099 # to avoid creating ambiguity when we escape the latter.
3103 # the insane complexity here is due to the behaviour of "\c\"
3104 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
3108 sub balanced_delim {
3110 my @str = split //, $str;
3111 my($ar, $open, $close, $fail, $c, $cnt);
3112 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
3113 ($open, $close) = @$ar;
3114 $fail = 0; $cnt = 0;
3118 } elsif ($c eq $close) {
3127 $fail = 1 if $cnt != 0;
3128 return ($open, "$open$str$close") if not $fail;
3134 my($q, $default, $str) = @_;
3135 return "$default$str$default" if $default and index($str, $default) == -1;
3136 my($succeed, $delim);
3137 ($succeed, $str) = balanced_delim($str);
3138 return "$q$str" if $succeed;
3139 for $delim ('/', '"', '#') {
3140 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3143 $str =~ s/$default/\\$default/g;
3144 return "$default$str$default";
3153 if (class($sv) eq "SPECIAL") {
3154 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
3155 } elsif (class($sv) eq "NULL") {
3157 } elsif ($sv->FLAGS & SVf_IOK) {
3158 return $sv->int_value;
3159 } elsif ($sv->FLAGS & SVf_NOK) {
3160 # try the default stringification
3163 # If it's in scientific notation, we might have lost information
3164 return sprintf("%.20e", $sv->NV);
3167 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3168 return "\\(" . const($sv->RV) . ")"; # constant folded
3169 } elsif ($sv->FLAGS & SVf_POK) {
3171 if ($str =~ /[^ -~]/) { # ASCII for non-printing
3172 return single_delim("qq", '"', uninterp escape_str unback $str);
3174 return single_delim("q", "'", unback $str);
3185 # the constant could be in the pad (under useithreads)
3186 $sv = $self->padval($op->targ) unless $$sv;
3193 if ($op->private & OPpCONST_ARYBASE) {
3196 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3197 # return $self->const_sv($op)->PV;
3199 my $sv = $self->const_sv($op);
3200 # return const($sv);
3202 return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
3208 my $type = $op->name;
3209 if ($type eq "const") {
3210 return '$[' if $op->private & OPpCONST_ARYBASE;
3211 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3212 } elsif ($type eq "concat") {
3213 my $first = $self->dq($op->first);
3214 my $last = $self->dq($op->last);
3216 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3217 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3218 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
3219 || ($last =~ /^[{\[\w_]/ &&
3220 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3222 return $first . $last;
3223 } elsif ($type eq "uc") {
3224 return '\U' . $self->dq($op->first->sibling) . '\E';
3225 } elsif ($type eq "lc") {
3226 return '\L' . $self->dq($op->first->sibling) . '\E';
3227 } elsif ($type eq "ucfirst") {
3228 return '\u' . $self->dq($op->first->sibling);
3229 } elsif ($type eq "lcfirst") {
3230 return '\l' . $self->dq($op->first->sibling);
3231 } elsif ($type eq "quotemeta") {
3232 return '\Q' . $self->dq($op->first->sibling) . '\E';
3233 } elsif ($type eq "join") {
3234 return $self->deparse($op->last, 26); # was join($", @ary)
3236 return $self->deparse($op, 26);
3244 return single_delim("qx", '`', $self->dq($op->first->sibling));
3250 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3251 return $self->deparse($kid, $cx) if $self->{'unquote'};
3252 $self->maybe_targmy($kid, $cx,
3253 sub {single_delim("qq", '"', $self->dq($_[1]))});
3256 # OP_STRINGIFY is a listop, but it only ever has one arg
3257 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3259 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3260 # note that tr(from)/to/ is OK, but not tr/from/(to)
3262 my($from, $to) = @_;
3263 my($succeed, $delim);
3264 if ($from !~ m[/] and $to !~ m[/]) {
3265 return "/$from/$to/";
3266 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3267 if (($succeed, $to) = balanced_delim($to) and $succeed) {
3270 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3271 return "$from$delim$to$delim" if index($to, $delim) == -1;
3274 return "$from/$to/";
3277 for $delim ('/', '"', '#') { # note no '
3278 return "$delim$from$delim$to$delim"
3279 if index($to . $from, $delim) == -1;
3281 $from =~ s[/][\\/]g;
3283 return "/$from/$to/";
3287 # Only used by tr///, so backslashes hyphens
3290 if ($n == ord '\\') {
3292 } elsif ($n == ord "-") {
3294 } elsif ($n >= ord(' ') and $n <= ord('~')) {
3296 } elsif ($n == ord "\a") {
3298 } elsif ($n == ord "\b") {
3300 } elsif ($n == ord "\t") {
3302 } elsif ($n == ord "\n") {
3304 } elsif ($n == ord "\e") {
3306 } elsif ($n == ord "\f") {
3308 } elsif ($n == ord "\r") {
3310 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3311 return '\\c' . chr(ord("@") + $n);
3313 # return '\x' . sprintf("%02x", $n);
3314 return '\\' . sprintf("%03o", $n);
3320 my($str, $c, $tr) = ("");
3321 for ($c = 0; $c < @chars; $c++) {
3324 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3325 $chars[$c + 2] == $tr + 2)
3327 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3330 $str .= pchr($chars[$c]);
3336 sub tr_decode_byte {
3337 my($table, $flags) = @_;
3338 my(@table) = unpack("s*", $table);
3339 splice @table, 0x100, 1; # Number of subsequent elements
3340 my($c, $tr, @from, @to, @delfrom, $delhyphen);
3341 if ($table[ord "-"] != -1 and
3342 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3344 $tr = $table[ord "-"];
3345 $table[ord "-"] = -1;
3349 } else { # -2 ==> delete
3353 for ($c = 0; $c < @table; $c++) {
3356 push @from, $c; push @to, $tr;
3357 } elsif ($tr == -2) {
3361 @from = (@from, @delfrom);
3362 if ($flags & OPpTRANS_COMPLEMENT) {
3365 @from{@from} = (1) x @from;
3366 for ($c = 0; $c < 256; $c++) {
3367 push @newfrom, $c unless $from{$c};
3371 unless ($flags & OPpTRANS_DELETE || !@to) {
3372 pop @to while $#to and $to[$#to] == $to[$#to -1];
3375 $from = collapse(@from);
3376 $to = collapse(@to);
3377 $from .= "-" if $delhyphen;
3378 return ($from, $to);
3383 if ($x == ord "-") {
3385 } elsif ($x == ord "\\") {
3392 # XXX This doesn't yet handle all cases correctly either
3394 sub tr_decode_utf8 {
3395 my($swash_hv, $flags) = @_;
3396 my %swash = $swash_hv->ARRAY;
3398 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3399 my $none = $swash{"NONE"}->IV;
3400 my $extra = $none + 1;
3401 my(@from, @delfrom, @to);
3403 foreach $line (split /\n/, $swash{'LIST'}->PV) {
3404 my($min, $max, $result) = split(/\t/, $line);
3411 $result = hex $result;
3412 if ($result == $extra) {
3413 push @delfrom, [$min, $max];
3415 push @from, [$min, $max];
3416 push @to, [$result, $result + $max - $min];
3419 for my $i (0 .. $#from) {
3420 if ($from[$i][0] == ord '-') {
3421 unshift @from, splice(@from, $i, 1);
3422 unshift @to, splice(@to, $i, 1);
3424 } elsif ($from[$i][1] == ord '-') {
3427 unshift @from, ord '-';
3428 unshift @to, ord '-';
3432 for my $i (0 .. $#delfrom) {
3433 if ($delfrom[$i][0] == ord '-') {
3434 push @delfrom, splice(@delfrom, $i, 1);
3436 } elsif ($delfrom[$i][1] == ord '-') {
3438 push @delfrom, ord '-';
3442 if (defined $final and $to[$#to][1] != $final) {
3443 push @to, [$final, $final];
3445 push @from, @delfrom;
3446 if ($flags & OPpTRANS_COMPLEMENT) {
3449 for my $i (0 .. $#from) {
3450 push @newfrom, [$next, $from[$i][0] - 1];
3451 $next = $from[$i][1] + 1;
3454 for my $range (@newfrom) {
3455 if ($range->[0] <= $range->[1]) {
3460 my($from, $to, $diff);
3461 for my $chunk (@from) {
3462 $diff = $chunk->[1] - $chunk->[0];
3464 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3465 } elsif ($diff == 1) {
3466 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3468 $from .= tr_chr($chunk->[0]);
3471 for my $chunk (@to) {
3472 $diff = $chunk->[1] - $chunk->[0];
3474 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3475 } elsif ($diff == 1) {
3476 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3478 $to .= tr_chr($chunk->[0]);
3481 #$final = sprintf("%04x", $final) if defined $final;
3482 #$none = sprintf("%04x", $none) if defined $none;
3483 #$extra = sprintf("%04x", $extra) if defined $extra;
3484 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3485 #print STDERR $swash{'LIST'}->PV;
3486 return (escape_str($from), escape_str($to));
3493 if (class($op) eq "PVOP") {
3494 ($from, $to) = tr_decode_byte($op->pv, $op->private);
3495 } else { # class($op) eq "SVOP"
3496 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3499 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3500 $flags .= "d" if $op->private & OPpTRANS_DELETE;
3501 $to = "" if $from eq $to and $flags eq "";
3502 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3503 return "tr" . double_delim($from, $to) . $flags;
3506 # Like dq(), but different
3509 my ($op, $extended) = @_;
3511 my $type = $op->name;
3512 if ($type eq "const") {
3513 return '$[' if $op->private & OPpCONST_ARYBASE;
3514 my $unbacked = re_unback($self->const_sv($op)->as_string);
3515 return re_uninterp_extended(escape_extended_re($unbacked))
3517 return re_uninterp(escape_str($unbacked));
3518 } elsif ($type eq "concat") {
3519 my $first = $self->re_dq($op->first, $extended);
3520 my $last = $self->re_dq($op->last, $extended);
3522 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3523 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3524 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
3525 || ($last =~ /^[{\[\w_]/ &&
3526 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3528 return $first . $last;
3529 } elsif ($type eq "uc") {
3530 return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
3531 } elsif ($type eq "lc") {
3532 return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
3533 } elsif ($type eq "ucfirst") {
3534 return '\u' . $self->re_dq($op->first->sibling, $extended);
3535 } elsif ($type eq "lcfirst") {
3536 return '\l' . $self->re_dq($op->first->sibling, $extended);
3537 } elsif ($type eq "quotemeta") {
3538 return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
3539 } elsif ($type eq "join") {
3540 return $self->deparse($op->last, 26); # was join($", @ary)
3542 return $self->deparse($op, 26);
3547 my ($self, $op) = @_;
3548 my $type = $op->name;
3550 if ($type eq 'const') {
3553 elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
3554 return $self->pure_string($op->first->sibling);
3556 elsif ($type eq 'join') {
3557 my $join_op = $op->first->sibling; # Skip pushmark
3558 return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
3560 my $gvop = $join_op->first;
3561 return 0 unless $gvop->name eq 'gvsv';
3562 return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
3564 return 0 unless ${$join_op->sibling} eq ${$op->last};
3565 return 0 unless $op->last->name =~ /^(rv2|pad)av$/;
3567 elsif ($type eq 'concat') {
3568 return $self->pure_string($op->first)
3569 && $self->pure_string($op->last);
3571 elsif (is_scalar($op) || $type =~ /^[ah]elem(fast)?$/) {
3583 my($op, $cx, $extended) = @_;
3584 my $kid = $op->first;
3585 $kid = $kid->first if $kid->name eq "regcmaybe";
3586 $kid = $kid->first if $kid->name eq "regcreset";
3587 return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
3588 return ($self->deparse($kid, $cx), 0);
3592 my ($self, $op, $cx) = @_;
3593 return (($self->regcomp($op, $cx, 0))[0]);
3596 # osmic acid -- see osmium tetroxide
3599 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3600 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3601 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3605 my($op, $cx, $name, $delim) = @_;
3606 my $kid = $op->first;
3607 my ($binop, $var, $re) = ("", "", "");
3608 if ($op->flags & OPf_STACKED) {
3610 $var = $self->deparse($kid, 20);
3611 $kid = $kid->sibling;
3614 my $extended = ($op->pmflags & PMf_EXTENDED);
3616 my $unbacked = re_unback($op->precomp);
3618 $re = re_uninterp_extended(escape_extended_re($unbacked));
3620 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3622 } elsif ($kid->name ne 'regcomp') {
3623 Carp::cluck("found ".$kid->name." where regcomp expected");
3625 ($re, $quote) = $self->regcomp($kid, 1, $extended);
3628 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3629 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3630 $flags .= "i" if $op->pmflags & PMf_FOLD;
3631 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3632 $flags .= "o" if $op->pmflags & PMf_KEEP;
3633 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3634 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3635 $flags = $matchwords{$flags} if $matchwords{$flags};
3636 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3640 $re = single_delim($name, $delim, $re);
3642 $re = $re . $flags if $quote;
3644 return $self->maybe_parens("$var =~ $re", $cx, 20);
3650 sub pp_match { matchop(@_, "m", "/") }
3651 sub pp_pushre { matchop(@_, "m", "/") }
3652 sub pp_qr { matchop(@_, "qr", "") }
3657 my($kid, @exprs, $ary, $expr);
3659 if ($ {$kid->pmreplroot}) {
3660 $ary = $self->stash_variable('@', $self->gv_name($kid->pmreplroot));
3662 for (; !null($kid); $kid = $kid->sibling) {
3663 push @exprs, $self->deparse($kid, 6);
3666 # handle special case of split(), and split(" ") that compiles to /\s+/
3668 if ($kid->flags & OPf_SPECIAL
3669 && $exprs[0] eq '/\\s+/'
3670 && $kid->pmflags & PMf_SKIPWHITE ) {
3674 $expr = "split(" . join(", ", @exprs) . ")";
3676 return $self->maybe_parens("$ary = $expr", $cx, 7);
3682 # oxime -- any of various compounds obtained chiefly by the action of
3683 # hydroxylamine on aldehydes and ketones and characterized by the
3684 # bivalent grouping C=NOH [Webster's Tenth]
3687 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3688 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3689 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3690 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3695 my $kid = $op->first;
3696 my($binop, $var, $re, $repl) = ("", "", "", "");
3697 if ($op->flags & OPf_STACKED) {
3699 $var = $self->deparse($kid, 20);
3700 $kid = $kid->sibling;
3703 if (null($op->pmreplroot)) {
3704 $repl = $self->dq($kid);
3705 $kid = $kid->sibling;
3707 $repl = $op->pmreplroot->first; # skip substcont
3708 while ($repl->name eq "entereval") {
3709 $repl = $repl->first;
3712 if ($op->pmflags & PMf_EVAL) {
3713 $repl = $self->deparse($repl, 0);
3715 $repl = $self->dq($repl);
3718 my $extended = ($op->pmflags & PMf_EXTENDED);
3720 my $unbacked = re_unback($op->precomp);
3722 $re = re_uninterp_extended(escape_extended_re($unbacked));
3725 $re = re_uninterp(escape_str($unbacked));
3728 ($re) = $self->regcomp($kid, 1, $extended);
3730 $flags .= "e" if $op->pmflags & PMf_EVAL;
3731 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3732 $flags .= "i" if $op->pmflags & PMf_FOLD;
3733 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3734 $flags .= "o" if $op->pmflags & PMf_KEEP;
3735 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3736 $flags .= "x" if $extended;
3737 $flags = $substwords{$flags} if $substwords{$flags};
3739 return $self->maybe_parens("$var =~ s"
3740 . double_delim($re, $repl) . $flags,
3743 return "s". double_delim($re, $repl) . $flags;
3752 B::Deparse - Perl compiler backend to produce perl code
3756 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3757 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3761 B::Deparse is a backend module for the Perl compiler that generates
3762 perl source code, based on the internal compiled structure that perl
3763 itself creates after parsing a program. The output of B::Deparse won't
3764 be exactly the same as the original source, since perl doesn't keep
3765 track of comments or whitespace, and there isn't a one-to-one
3766 correspondence between perl's syntactical constructions and their
3767 compiled form, but it will often be close. When you use the B<-p>
3768 option, the output also includes parentheses even when they are not
3769 required by precedence, which can make it easy to see if perl is
3770 parsing your expressions the way you intended.
3772 Please note that this module is mainly new and untested code and is
3773 still under development, so it may change in the future.
3777 As with all compiler backend options, these must follow directly after
3778 the '-MO=Deparse', separated by a comma but not any white space.
3784 Add '#line' declarations to the output based on the line and file
3785 locations of the original code.
3789 Print extra parentheses. Without this option, B::Deparse includes
3790 parentheses in its output only when they are needed, based on the
3791 structure of your program. With B<-p>, it uses parentheses (almost)
3792 whenever they would be legal. This can be useful if you are used to
3793 LISP, or if you want to see how perl parses your input. If you say
3795 if ($var & 0x7f == 65) {print "Gimme an A!"}
3796 print ($which ? $a : $b), "\n";
3797 $name = $ENV{USER} or "Bob";
3799 C<B::Deparse,-p> will print
3802 print('Gimme an A!')
3804 (print(($which ? $a : $b)), '???');
3805 (($name = $ENV{'USER'}) or '???')
3807 which probably isn't what you intended (the C<'???'> is a sign that
3808 perl optimized away a constant value).
3812 Expand double-quoted strings into the corresponding combinations of
3813 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3816 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3820 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3821 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3823 Note that the expanded form represents the way perl handles such
3824 constructions internally -- this option actually turns off the reverse
3825 translation that B::Deparse usually does. On the other hand, note that
3826 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3827 of $y into a string before doing the assignment.
3831 Normally, B::Deparse deparses the main code of a program, and all the subs
3832 defined in the same file. To include subs defined in other files, pass the
3833 B<-f> option with the filename. You can pass the B<-f> option several times, to
3834 include more than one secondary file. (Most of the time you don't want to
3835 use it at all.) You can also use this option to include subs which are
3836 defined in the scope of a B<#line> directive with two parameters.
3838 =item B<-s>I<LETTERS>
3840 Tweak the style of B::Deparse's output. The letters should follow
3841 directly after the 's', with no space or punctuation. The following
3842 options are available:
3848 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3865 The default is not to cuddle.
3869 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3873 Use tabs for each 8 columns of indent. The default is to use only spaces.
3874 For instance, if the style options are B<-si4T>, a line that's indented
3875 3 times will be preceded by one tab and four spaces; if the options were
3876 B<-si8T>, the same line would be preceded by three tabs.
3878 =item B<v>I<STRING>B<.>
3880 Print I<STRING> for the value of a constant that can't be determined
3881 because it was optimized away (mnemonic: this happens when a constant
3882 is used in B<v>oid context). The end of the string is marked by a period.
3883 The string should be a valid perl expression, generally a constant.
3884 Note that unless it's a number, it probably needs to be quoted, and on
3885 a command line quotes need to be protected from the shell. Some
3886 conventional values include 0, 1, 42, '', 'foo', and
3887 'Useless use of constant omitted' (which may need to be
3888 B<-sv"'Useless use of constant omitted'.">
3889 or something similar depending on your shell). The default is '???'.
3890 If you're using B::Deparse on a module or other file that's require'd,
3891 you shouldn't use a value that evaluates to false, since the customary
3892 true constant at the end of a module will be in void context when the
3893 file is compiled as a main program.
3899 Expand conventional syntax constructions into equivalent ones that expose
3900 their internal operation. I<LEVEL> should be a digit, with higher values
3901 meaning more expansion. As with B<-q>, this actually involves turning off
3902 special cases in B::Deparse's normal operations.
3904 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3905 while loops with continue blocks; for instance
3907 for ($i = 0; $i < 10; ++$i) {
3920 Note that in a few cases this translation can't be perfectly carried back
3921 into the source code -- if the loop's initializer declares a my variable,
3922 for instance, it won't have the correct scope outside of the loop.
3924 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3925 expressions using C<&&>, C<?:> and C<do {}>; for instance
3927 print 'hi' if $nice;
3939 $nice and print 'hi';
3940 $nice and do { print 'hi' };
3941 $nice ? do { print 'hi' } : do { print 'bye' };
3943 Long sequences of elsifs will turn into nested ternary operators, which
3944 B::Deparse doesn't know how to indent nicely.
3948 =head1 USING B::Deparse AS A MODULE
3953 $deparse = B::Deparse->new("-p", "-sC");
3954 $body = $deparse->coderef2text(\&func);
3955 eval "sub func $body"; # the inverse operation
3959 B::Deparse can also be used on a sub-by-sub basis from other perl
3964 $deparse = B::Deparse->new(OPTIONS)
3966 Create an object to store the state of a deparsing operation and any
3967 options. The options are the same as those that can be given on the
3968 command line (see L</OPTIONS>); options that are separated by commas
3969 after B<-MO=Deparse> should be given as separate strings. Some
3970 options, like B<-u>, don't make sense for a single subroutine, so
3973 =head2 ambient_pragmas
3975 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3977 The compilation of a subroutine can be affected by a few compiler
3978 directives, B<pragmas>. These are:
3992 Assigning to the special variable $[
4012 Ordinarily, if you use B::Deparse on a subroutine which has
4013 been compiled in the presence of one or more of these pragmas,
4014 the output will include statements to turn on the appropriate
4015 directives. So if you then compile the code returned by coderef2text,
4016 it will behave the same way as the subroutine which you deparsed.
4018 However, you may know that you intend to use the results in a
4019 particular context, where some pragmas are already in scope. In
4020 this case, you use the B<ambient_pragmas> method to describe the
4021 assumptions you wish to make.
4023 Not all of the options currently have any useful effect. See
4024 L</BUGS> for more details.
4026 The parameters it accepts are:
4032 Takes a string, possibly containing several values separated
4033 by whitespace. The special values "all" and "none" mean what you'd
4036 $deparse->ambient_pragmas(strict => 'subs refs');
4040 Takes a number, the value of the array base $[.
4048 If the value is true, then the appropriate pragma is assumed to
4049 be in the ambient scope, otherwise not.
4053 Takes a string, possibly containing a whitespace-separated list of
4054 values. The values "all" and "none" are special. It's also permissible
4055 to pass an array reference here.
4057 $deparser->ambient_pragmas(re => 'eval');
4062 Takes a string, possibly containing a whitespace-separated list of
4063 values. The values "all" and "none" are special, again. It's also
4064 permissible to pass an array reference here.
4066 $deparser->ambient_pragmas(warnings => [qw[void io]]);
4068 If one of the values is the string "FATAL", then all the warnings
4069 in that list will be considered fatal, just as with the B<warnings>
4070 pragma itself. Should you need to specify that some warnings are
4071 fatal, and others are merely enabled, you can pass the B<warnings>
4074 $deparser->ambient_pragmas(
4076 warnings => [FATAL => qw/void io/],
4079 See L<perllexwarn> for more information about lexical warnings.
4085 These two parameters are used to specify the ambient pragmas in
4086 the format used by the special variables $^H and ${^WARNING_BITS}.
4088 They exist principally so that you can write code like:
4090 { my ($hint_bits, $warning_bits);
4091 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
4092 $deparser->ambient_pragmas (
4093 hint_bits => $hint_bits,
4094 warning_bits => $warning_bits,
4098 which specifies that the ambient pragmas are exactly those which
4099 are in scope at the point of calling.
4105 $body = $deparse->coderef2text(\&func)
4106 $body = $deparse->coderef2text(sub ($$) { ... })
4108 Return source code for the body of a subroutine (a block, optionally
4109 preceded by a prototype in parens), given a reference to the
4110 sub. Because a subroutine can have no names, or more than one name,
4111 this method doesn't return a complete subroutine definition -- if you
4112 want to eval the result, you should prepend "sub subname ", or "sub "
4113 for an anonymous function constructor. Unless the sub was defined in
4114 the main:: package, the code will include a package declaration.
4122 The only pragmas to be completely supported are: C<use warnings>,
4123 C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
4124 behaves like a pragma, is also supported.)
4126 Excepting those listed above, we're currently unable to guarantee that
4127 B::Deparse will produce a pragma at the correct point in the program.
4128 Since the effects of pragmas are often lexically scoped, this can mean
4129 that the pragma holds sway over a different portion of the program
4130 than in the input file.
4134 In fact, the above is a specific instance of a more general problem:
4135 we can't guarantee to produce BEGIN blocks or C<use> declarations in
4136 exactly the right place. So if you use a module which affects compilation
4137 (such as by over-riding keywords, overloading constants or whatever)
4138 then the output code might not work as intended.
4140 This is the most serious outstanding problem, and will be very hard
4145 If a keyword is over-ridden, and your program explicitly calls
4146 the built-in version by using CORE::keyword, the output of B::Deparse
4147 will not reflect this. If you run the resulting code, it will call
4148 the over-ridden version rather than the built-in one. (Maybe there
4149 should be an option to B<always> print keyword calls as C<CORE::name>.)
4153 C<sort foo (1, 2, 3)> comes out as C<sort (foo 1, 2, 3)>, which
4154 causes perl to issue a warning.
4156 The obvious fix doesn't work, because these are different:
4158 print (FOO 1, 2, 3), 4, 5, 6;
4159 print FOO (1, 2, 3), 4, 5, 6;
4163 Constants (other than simple strings or numbers) don't work properly.
4164 Pathological examples that fail (and probably always will) include:
4166 use constant E2BIG => ($!=7);
4167 use constant x=>\$x; print x
4169 The following could (and should) be made to work:
4171 use constant regex => qr/blah/;
4176 An input file that uses source filtering probably won't be deparsed into
4177 runnable code, because it will still include the B<use> declaration
4178 for the source filtering module, even though the code that is
4179 produced is already ordinary Perl which shouldn't be filtered again.
4183 There are probably many more bugs on non-ASCII platforms (EBCDIC).
4189 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
4190 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
4191 contributions from Gisle Aas, James Duncan, Albert Dvornik, Robin
4192 Houston, Hugo van der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.