2 # Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved.
3 # This module is free software; you can redistribute and/or modify
4 # it under the same terms as Perl itself.
6 # This is based on the module of the same name by Malcolm Beattie,
7 # but essentially none of his code remains.
10 use Carp 'cluck', 'croak';
11 use B qw(class main_root main_start main_cv svref_2object opnumber cstring
12 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
13 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
14 OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
15 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
17 SVf_IOK SVf_NOK SVf_ROK SVf_POK
18 CVf_METHOD CVf_LOCKED CVf_LVALUE
19 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
20 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
24 # Changes between 0.50 and 0.51:
25 # - fixed nulled leave with live enter in sort { }
26 # - fixed reference constants (\"str")
27 # - handle empty programs gracefully
28 # - handle infinte loops (for (;;) {}, while (1) {})
29 # - differentiate between `for my $x ...' and `my $x; for $x ...'
30 # - various minor cleanups
31 # - moved globals into an object
32 # - added `-u', like B::C
33 # - package declarations using cop_stash
34 # - subs, formats and code sorted by cop_seq
35 # Changes between 0.51 and 0.52:
36 # - added pp_threadsv (special variables under USE_THREADS)
37 # - added documentation
38 # Changes between 0.52 and 0.53:
39 # - many changes adding precedence contexts and associativity
40 # - added `-p' and `-s' output style options
41 # - various other minor fixes
42 # Changes between 0.53 and 0.54:
43 # - added support for new `for (1..100)' optimization,
45 # Changes between 0.54 and 0.55:
46 # - added support for new qr// construct
47 # - added support for new pp_regcreset OP
48 # Changes between 0.55 and 0.56:
49 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
50 # - fixed $# on non-lexicals broken in last big rewrite
51 # - added temporary fix for change in opcode of OP_STRINGIFY
52 # - fixed problem in 0.54's for() patch in `for (@ary)'
53 # - fixed precedence in conditional of ?:
54 # - tweaked list paren elimination in `my($x) = @_'
55 # - made continue-block detection trickier wrt. null ops
56 # - fixed various prototype problems in pp_entersub
57 # - added support for sub prototypes that never get GVs
58 # - added unquoting for special filehandle first arg in truncate
59 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
60 # - added semicolons at the ends of blocks
61 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
62 # Changes between 0.56 and 0.561:
63 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
64 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
65 # Changes between 0.561 and 0.57:
66 # - stylistic changes to symbolic constant stuff
67 # - handled scope in s///e replacement code
68 # - added unquote option for expanding "" into concats, etc.
69 # - split method and proto parts of pp_entersub into separate functions
70 # - various minor cleanups
72 # - added parens in \&foo (patch by Albert Dvornik)
73 # Changes between 0.57 and 0.58:
74 # - fixed `0' statements that weren't being printed
75 # - added methods for use from other programs
76 # (based on patches from James Duncan and Hugo van der Sanden)
77 # - added -si and -sT to control indenting (also based on a patch from Hugo)
78 # - added -sv to print something else instead of '???'
79 # - preliminary version of utf8 tr/// handling
81 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
82 # - added support for Hugo's new OP_SETSTATE (like nextstate)
83 # Changes between 0.58 and 0.59
84 # - added support for Chip's OP_METHOD_NAMED
85 # - added support for Ilya's OPpTARGET_MY optimization
86 # - elided arrows before `()' subscripts when possible
87 # Changes between 0.59 and 0.60
88 # - support for method attribues was added
89 # - some warnings fixed
90 # - separate recognition of constant subs
91 # - rewrote continue block handling, now recoginizing for loops
92 # - added more control of expanding control structures
95 # - finish tr/// changes
96 # - add option for even more parens (generalize \&foo change)
97 # - left/right context
98 # - recognize `use utf8', `use integer', etc
99 # - treat top-level block specially for incremental output
100 # - interpret high bit chars in string as utf8 \x{...} (when?)
101 # - copy comments (look at real text with $^P?)
102 # - avoid semis in one-statement blocks
103 # - associativity of &&=, ||=, ?:
104 # - ',' => '=>' (auto-unquote?)
105 # - break long lines ("\r" as discretionary break?)
106 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
107 # - more style options: brace style, hex vs. octal, quotes, ...
108 # - print big ints as hex/octal instead of decimal (heuristic?)
109 # - handle `my $x if 0'?
110 # - include values of variables (e.g. set in BEGIN)
111 # - coordinate with Data::Dumper (both directions? see previous)
112 # - version using op_next instead of op_first/sibling?
113 # - avoid string copies (pass arrays, one big join?)
115 # - -uPackage:: descend recursively?
119 # Tests that will always fail:
120 # comp/redef.t -- all (redefinition happens at compile time)
122 # Object fields (were globals):
125 # (local($a), local($b)) and local($a, $b) have the same internal
126 # representation but the short form looks better. We notice we can
127 # use a large-scale local when checking the list, but need to prevent
128 # individual locals too. This hash holds the addresses of OPs that
129 # have already had their local-ness accounted for. The same thing
133 # CV for current sub (or main program) being deparsed
136 # name of the current package for deparsed code
139 # array of [cop_seq, GV, is_format?] for subs and formats we still
143 # as above, but [name, prototype] for subs that never got a GV
145 # subs_done, forms_done:
146 # keys are addresses of GVs for subs and formats we've already
147 # deparsed (or at least put into subs_todo)
150 # keys are names of subs for which we've printed declarations.
151 # That means we can omit parentheses from the arguments.
156 # cuddle: ` ' or `\n', depending on -sC
161 # A little explanation of how precedence contexts and associativity
164 # deparse() calls each per-op subroutine with an argument $cx (short
165 # for context, but not the same as the cx* in the perl core), which is
166 # a number describing the op's parents in terms of precedence, whether
167 # they're inside an expression or at statement level, etc. (see
168 # chart below). When ops with children call deparse on them, they pass
169 # along their precedence. Fractional values are used to implement
170 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
171 # parentheses hacks. The major disadvantage of this scheme is that
172 # it doesn't know about right sides and left sides, so say if you
173 # assign a listop to a variable, it can't tell it's allowed to leave
174 # the parens off the listop.
177 # 26 [TODO] inside interpolation context ("")
178 # 25 left terms and list operators (leftward)
182 # 21 right ! ~ \ and unary + and -
187 # 16 nonassoc named unary operators
188 # 15 nonassoc < > <= >= lt gt le ge
189 # 14 nonassoc == != <=> eq ne cmp
196 # 7 right = += -= *= etc.
198 # 5 nonassoc list operators (rightward)
202 # 1 statement modifiers
205 # Nonprinting characters with special meaning:
206 # \cS - steal parens (see maybe_parens_unop)
207 # \n - newline and indent
208 # \t - increase indent
209 # \b - decrease indent (`outdent')
210 # \f - flush left (no indent)
211 # \cK - kill following semicolon, if any
215 return class($op) eq "NULL";
220 my($gv, $cv, $is_form) = @_;
222 if (!null($cv->START) and is_state($cv->START)) {
223 $seq = $cv->START->cop_seq;
227 push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
232 my $ent = shift @{$self->{'subs_todo'}};
233 my $name = $self->gv_name($ent->[1]);
235 return "format $name =\n"
236 . $self->deparse_format($ent->[1]->FORM). "\n";
238 $self->{'subs_declared'}{$name} = 1;
239 return "sub $name " . $self->deparse_sub($ent->[1]->CV);
246 if ($op->flags & OPf_KIDS) {
248 for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
249 walk_tree($kid, $sub);
258 $op = shift if null $op;
259 return if !$op or null $op;
262 if ($op->name eq "gv") {
263 my $gv = $self->gv_or_padgv($op);
264 if ($op->next->name eq "entersub") {
265 return if $self->{'subs_done'}{$$gv}++;
266 return if class($gv->CV) eq "SPECIAL";
267 $self->todo($gv, $gv->CV, 0);
268 $self->walk_sub($gv->CV);
269 } elsif ($op->next->name eq "enterwrite"
270 or ($op->next->name eq "rv2gv"
271 and $op->next->next->name eq "enterwrite")) {
272 return if $self->{'forms_done'}{$$gv}++;
273 return if class($gv->FORM) eq "SPECIAL";
274 $self->todo($gv, $gv->FORM, 1);
275 $self->walk_sub($gv->FORM);
285 { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
286 if ($pack eq "main") {
289 $pack = $pack . "::";
292 while (($key, $val) = each %stash) {
293 my $class = class($val);
294 if ($class eq "PV") {
296 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
297 } elsif ($class eq "IV") {
299 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
300 } elsif ($class eq "GV") {
301 if (class($val->CV) ne "SPECIAL") {
302 next if $self->{'subs_done'}{$$val}++;
303 $self->todo($val, $val->CV, 0);
304 $self->walk_sub($val->CV);
306 if (class($val->FORM) ne "SPECIAL") {
307 next if $self->{'forms_done'}{$$val}++;
308 $self->todo($val, $val->FORM, 1);
309 $self->walk_sub($val->FORM);
319 foreach $ar (@{$self->{'protos_todo'}}) {
320 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
321 push @ret, "sub " . $ar->[0] . "$proto;\n";
323 delete $self->{'protos_todo'};
331 while (length($opt = substr($opts, 0, 1))) {
333 $self->{'cuddle'} = " ";
334 $opts = substr($opts, 1);
335 } elsif ($opt eq "i") {
336 $opts =~ s/^i(\d+)//;
337 $self->{'indent_size'} = $1;
338 } elsif ($opt eq "T") {
339 $self->{'use_tabs'} = 1;
340 $opts = substr($opts, 1);
341 } elsif ($opt eq "v") {
342 $opts =~ s/^v([^.]*)(.|$)//;
343 $self->{'ex_const'} = $1;
350 my $self = bless {}, $class;
351 $self->{'subs_todo'} = [];
352 $self->{'curstash'} = "main";
353 $self->{'cuddle'} = "\n";
354 $self->{'indent_size'} = 4;
355 $self->{'use_tabs'} = 0;
356 $self->{'expand'} = 0;
357 $self->{'unquote'} = 0;
358 $self->{'linenums'} = 0;
359 $self->{'parens'} = 0;
360 $self->{'ex_const'} = "'???'";
362 $self->{'ambient_arybase'} = 0;
363 $self->{'ambient_warnings'} = "\0"x12;
366 while (my $arg = shift @_) {
367 if (substr($arg, 0, 2) eq "-u") {
368 $self->stash_subs(substr($arg, 2));
369 } elsif ($arg eq "-p") {
370 $self->{'parens'} = 1;
371 } elsif ($arg eq "-l") {
372 $self->{'linenums'} = 1;
373 } elsif ($arg eq "-q") {
374 $self->{'unquote'} = 1;
375 } elsif (substr($arg, 0, 2) eq "-s") {
376 $self->style_opts(substr $arg, 2);
377 } elsif ($arg =~ /^-x(\d)$/) {
378 $self->{'expand'} = $1;
384 # Initialise the contextual information, either from
385 # defaults provided with the ambient_pragmas method,
386 # or from perl's own defaults otherwise.
390 $self->{'arybase'} = $self->{'ambient_arybase'};
391 $self->{'warnings'} = $self->{'ambient_warnings'};
397 my $self = B::Deparse->new(@args);
398 $self->stash_subs("main");
399 $self->{'curcv'} = main_cv;
400 $self->walk_sub(main_cv, main_start);
401 print $self->print_protos;
402 @{$self->{'subs_todo'}} =
403 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
404 print $self->indent($self->deparse(main_root, 0)), "\n"
405 unless null main_root;
407 while (scalar(@{$self->{'subs_todo'}})) {
408 push @text, $self->next_todo;
410 print $self->indent(join("", @text)), "\n" if @text;
417 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
420 return $self->indent($self->deparse_sub(svref_2object($sub)));
423 sub ambient_pragmas {
425 my ($arybase, $hint_bits, $warning_bits) = (0, 0, "\0"x12);
431 if ($name eq 'strict') {
434 if ($val eq 'none') {
435 $hint_bits &= ~strict::bits(qw/refs subs vars/);
441 @names = qw/refs subs vars/;
447 @names = split/\s+/, $val;
449 $hint_bits |= strict::bits(@names);
452 elsif ($name eq '$[') {
456 elsif ($name eq 'integer') {
459 $hint_bits |= $integer::hint_bits;
462 $hint_bits &= ~$integer::hint_bits;
466 elsif ($name eq 'warnings') {
468 if ($val eq 'none') {
469 $warning_bits = "\0"x12;
478 @names = split/\s+/, $val;
481 $warning_bits |= warnings::bits(@names);
484 elsif ($name eq 'warning_bits') {
485 $warning_bits = $val;
488 elsif ($name eq 'hint_bits') {
493 croak "Unknown pragma type: $name";
497 croak "The ambient_pragmas method expects an even number of args";
500 $self->{'ambient_arybase'} = $arybase;
501 $self->{'ambient_warnings'} = $warning_bits;
503 # $^H pragmas not yet implemented here
509 # cluck if class($op) eq "NULL";
511 # return $self->$ {\("pp_" . $op->name)}($op, $cx);
513 Carp::confess() unless defined $op;
514 my $meth = "pp_" . $op->name;
515 return $self->$meth($op, $cx);
521 my @lines = split(/\n/, $txt);
526 my $cmd = substr($line, 0, 1);
527 if ($cmd eq "\t" or $cmd eq "\b") {
528 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
529 if ($self->{'use_tabs'}) {
530 $leader = "\t" x ($level / 8) . " " x ($level % 8);
532 $leader = " " x $level;
534 $line = substr($line, 1);
536 if (substr($line, 0, 1) eq "\f") {
537 $line = substr($line, 1); # no indent
539 $line = $leader . $line;
543 return join("\n", @lines);
550 if ($cv->FLAGS & SVf_POK) {
551 $proto = "(". $cv->PV . ") ";
553 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
555 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
556 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
557 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
560 local($self->{'curcv'}) = $cv;
561 local($self->{'curstash'}) = $self->{'curstash'};
562 if (not null $cv->ROOT) {
564 return $proto . "{\n\t" .
565 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
567 my $sv = $cv->const_sv;
569 # uh-oh. inlinable sub... format it differently
570 return $proto . "{ " . const($sv) . " }\n";
572 return $proto . "{}\n";
580 local($self->{'curcv'}) = $form;
581 local($self->{'curstash'}) = $self->{'curstash'};
582 my $op = $form->ROOT;
584 $op = $op->first->first; # skip leavewrite, lineseq
585 while (not null $op) {
586 $op = $op->sibling; # skip nextstate
588 $kid = $op->first->sibling; # skip pushmark
589 push @text, $self->const_sv($kid)->PV;
590 $kid = $kid->sibling;
591 for (; not null $kid; $kid = $kid->sibling) {
592 push @exprs, $self->deparse($kid, 0);
594 push @text, join(", ", @exprs)."\n" if @exprs;
597 return join("", @text) . ".";
602 return $op->name eq "leave" || $op->name eq "scope"
603 || $op->name eq "lineseq"
604 || ($op->name eq "null" && class($op) eq "UNOP"
605 && (is_scope($op->first) || $op->first->name eq "enter"));
609 my $name = $_[0]->name;
610 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
613 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
615 return (!null($op) and null($op->sibling)
616 and $op->name eq "null" and class($op) eq "UNOP"
617 and (($op->first->name =~ /^(and|or)$/
618 and $op->first->first->sibling->name eq "lineseq")
619 or ($op->first->name eq "lineseq"
620 and not null $op->first->first->sibling
621 and $op->first->first->sibling->name eq "unstack")
627 return ($op->name eq "rv2sv" or
628 $op->name eq "padsv" or
629 $op->name eq "gv" or # only in array/hash constructs
630 $op->flags & OPf_KIDS && !null($op->first)
631 && $op->first->name eq "gvsv");
636 my($text, $cx, $prec) = @_;
637 if ($prec < $cx # unary ops nest just fine
638 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
639 or $self->{'parens'})
642 # In a unop, let parent reuse our parens; see maybe_parens_unop
643 $text = "\cS" . $text if $cx == 16;
650 # same as above, but get around the `if it looks like a function' rule
651 sub maybe_parens_unop {
653 my($name, $kid, $cx) = @_;
654 if ($cx > 16 or $self->{'parens'}) {
655 return "$name(" . $self->deparse($kid, 1) . ")";
657 $kid = $self->deparse($kid, 16);
658 if (substr($kid, 0, 1) eq "\cS") {
660 return $name . substr($kid, 1);
661 } elsif (substr($kid, 0, 1) eq "(") {
662 # avoid looks-like-a-function trap with extra parens
663 # (`+' can lead to ambiguities)
664 return "$name(" . $kid . ")";
671 sub maybe_parens_func {
673 my($func, $text, $cx, $prec) = @_;
674 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
675 return "$func($text)";
677 return "$func $text";
683 my($op, $cx, $text) = @_;
684 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
685 if (want_scalar($op)) {
686 return "local $text";
688 return $self->maybe_parens_func("local", $text, $cx, 16);
697 my($op, $cx, $func, @args) = @_;
698 if ($op->private & OPpTARGET_MY) {
699 my $var = $self->padname($op->targ);
700 my $val = $func->($self, $op, 7, @args);
701 return $self->maybe_parens("$var = $val", $cx, 7);
703 return $func->($self, $op, $cx, @args);
710 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
715 my($op, $cx, $text) = @_;
716 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
717 if (want_scalar($op)) {
720 return $self->maybe_parens_func("my", $text, $cx, 16);
727 # The following OPs don't have functions:
729 # pp_padany -- does not exist after parsing
730 # pp_rcatline -- does not exist
732 sub pp_enter { # see also leave
733 cluck "unexpected OP_ENTER";
737 sub pp_pushmark { # see also list
738 cluck "unexpected OP_PUSHMARK";
742 sub pp_leavesub { # see also deparse_sub
743 cluck "unexpected OP_LEAVESUB";
747 sub pp_leavewrite { # see also deparse_format
748 cluck "unexpected OP_LEAVEWRITE";
752 sub pp_method { # see also entersub
753 cluck "unexpected OP_METHOD";
757 sub pp_regcmaybe { # see also regcomp
758 cluck "unexpected OP_REGCMAYBE";
762 sub pp_regcreset { # see also regcomp
763 cluck "unexpected OP_REGCRESET";
767 sub pp_substcont { # see also subst
768 cluck "unexpected OP_SUBSTCONT";
772 sub pp_grepstart { # see also grepwhile
773 cluck "unexpected OP_GREPSTART";
777 sub pp_mapstart { # see also mapwhile
778 cluck "unexpected OP_MAPSTART";
782 sub pp_flip { # see also flop
783 cluck "unexpected OP_FLIP";
787 sub pp_iter { # see also leaveloop
788 cluck "unexpected OP_ITER";
792 sub pp_enteriter { # see also leaveloop
793 cluck "unexpected OP_ENTERITER";
797 sub pp_enterloop { # see also leaveloop
798 cluck "unexpected OP_ENTERLOOP";
802 sub pp_leaveeval { # see also entereval
803 cluck "unexpected OP_LEAVEEVAL";
807 sub pp_entertry { # see also leavetry
808 cluck "unexpected OP_ENTERTRY";
816 for (my $i = 0; $i < @ops; $i++) {
818 if (is_state $ops[$i]) {
819 $expr = $self->deparse($ops[$i], 0);
823 if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and
824 $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3)
826 push @exprs, $expr . $self->for_loop($ops[$i], 0);
830 $expr .= $self->deparse($ops[$i], 0);
831 push @exprs, $expr if length $expr;
833 for(@exprs[0..@exprs-1]) { s/;\n\z// }
834 return join(";\n", @exprs);
838 my($real_block, $self, $op, $cx) = @_;
841 local($self->{'curstash'}) = $self->{'curstash'} if $real_block;
843 $kid = $op->first->sibling; # skip enter
844 if (is_miniwhile($kid)) {
845 my $top = $kid->first;
846 my $name = $top->name;
847 if ($name eq "and") {
849 } elsif ($name eq "or") {
851 } else { # no conditional -> while 1 or until 0
852 return $self->deparse($top->first, 1) . " while 1";
854 my $cond = $top->first;
855 my $body = $cond->sibling->first; # skip lineseq
856 $cond = $self->deparse($cond, 1);
857 $body = $self->deparse($body, 1);
858 return "$body $name $cond";
863 for (; !null($kid); $kid = $kid->sibling) {
866 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
867 return "do { " . $self->lineseq(@kids) . " }";
869 my $lineseq = $self->lineseq(@kids);
870 return (length ($lineseq) ? "$lineseq;" : "");
874 sub pp_scope { scopeop(0, @_); }
875 sub pp_lineseq { scopeop(0, @_); }
876 sub pp_leave { scopeop(1, @_); }
878 # The BEGIN {} is used here because otherwise this code isn't executed
879 # when you run B::Deparse on itself.
881 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
882 "ENV", "ARGV", "ARGVOUT", "_"); }
887 my $stash = $gv->STASH->NAME;
888 my $name = $gv->SAFENAME;
889 if ($stash eq $self->{'curstash'} or $globalnames{$name}
890 or $name =~ /^[^A-Za-z_]/)
894 $stash = $stash . "::";
896 if ($name =~ /^\^../) {
897 $name = "{$name}"; # ${^WARNING_BITS} etc
899 return $stash . $name;
902 # Notice how subs and formats are inserted between statements here;
903 # also $[ assignments and the warnings pragma.
908 @text = $op->label . ": " if $op->label;
909 my $seq = $op->cop_seq;
910 while (scalar(@{$self->{'subs_todo'}})
911 and $seq >= $self->{'subs_todo'}[0][0]) {
912 push @text, $self->next_todo;
914 my $stash = $op->stashpv;
915 if ($stash ne $self->{'curstash'}) {
916 push @text, "package $stash;\n";
917 $self->{'curstash'} = $stash;
919 if ($self->{'linenums'}) {
920 push @text, "\f#line " . $op->line .
921 ' "' . $op->file, qq'"\n';
924 if ($self->{'arybase'} != $op->arybase) {
925 push @text, '$[ = '. $op->arybase .";\n";
926 $self->{'arybase'} = $op->arybase;
929 my $warnings = $op->warnings;
931 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
932 $warning_bits = $warnings::Bits{"all"};
934 elsif ($warnings->isa("B::SPECIAL")) {
935 $warning_bits = "\0"x12;
938 $warning_bits = $warnings->PV;
941 if ($self->{'warnings'} ne $warning_bits) {
942 push @text, declare_warnings($self->{'warnings'}, $warning_bits);
943 $self->{'warnings'} = $warning_bits;
946 return join("", @text);
949 sub declare_warnings {
950 my ($from, $to) = @_;
951 return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."};\n";
954 sub pp_dbstate { pp_nextstate(@_) }
955 sub pp_setstate { pp_nextstate(@_) }
957 sub pp_unstack { return "" } # see also leaveloop
961 my($op, $cx, $name) = @_;
965 sub pp_stub { baseop(@_, "()") }
966 sub pp_wantarray { baseop(@_, "wantarray") }
967 sub pp_fork { baseop(@_, "fork") }
968 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
969 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
970 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
971 sub pp_tms { baseop(@_, "times") }
972 sub pp_ghostent { baseop(@_, "gethostent") }
973 sub pp_gnetent { baseop(@_, "getnetent") }
974 sub pp_gprotoent { baseop(@_, "getprotoent") }
975 sub pp_gservent { baseop(@_, "getservent") }
976 sub pp_ehostent { baseop(@_, "endhostent") }
977 sub pp_enetent { baseop(@_, "endnetent") }
978 sub pp_eprotoent { baseop(@_, "endprotoent") }
979 sub pp_eservent { baseop(@_, "endservent") }
980 sub pp_gpwent { baseop(@_, "getpwent") }
981 sub pp_spwent { baseop(@_, "setpwent") }
982 sub pp_epwent { baseop(@_, "endpwent") }
983 sub pp_ggrent { baseop(@_, "getgrent") }
984 sub pp_sgrent { baseop(@_, "setgrent") }
985 sub pp_egrent { baseop(@_, "endgrent") }
986 sub pp_getlogin { baseop(@_, "getlogin") }
990 # I couldn't think of a good short name, but this is the category of
991 # symbolic unary operators with interesting precedence
995 my($op, $cx, $name, $prec, $flags) = (@_, 0);
996 my $kid = $op->first;
997 $kid = $self->deparse($kid, $prec);
998 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1002 sub pp_preinc { pfixop(@_, "++", 23) }
1003 sub pp_predec { pfixop(@_, "--", 23) }
1004 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1005 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1006 sub pp_i_preinc { pfixop(@_, "++", 23) }
1007 sub pp_i_predec { pfixop(@_, "--", 23) }
1008 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1009 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1010 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1012 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1016 if ($op->first->name =~ /^(i_)?negate$/) {
1018 $self->pfixop($op, $cx, "-", 21.5);
1020 $self->pfixop($op, $cx, "-", 21);
1023 sub pp_i_negate { pp_negate(@_) }
1029 $self->pfixop($op, $cx, "not ", 4);
1031 $self->pfixop($op, $cx, "!", 21);
1037 my($op, $cx, $name) = @_;
1039 if ($op->flags & OPf_KIDS) {
1041 return $self->maybe_parens_unop($name, $kid, $cx);
1043 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1047 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1048 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1049 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1050 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1051 sub pp_defined { unop(@_, "defined") }
1052 sub pp_undef { unop(@_, "undef") }
1053 sub pp_study { unop(@_, "study") }
1054 sub pp_ref { unop(@_, "ref") }
1055 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1057 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1058 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1059 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1060 sub pp_srand { unop(@_, "srand") }
1061 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1062 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1063 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1064 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1065 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1066 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1067 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1069 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1070 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1071 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1073 sub pp_each { unop(@_, "each") }
1074 sub pp_values { unop(@_, "values") }
1075 sub pp_keys { unop(@_, "keys") }
1076 sub pp_pop { unop(@_, "pop") }
1077 sub pp_shift { unop(@_, "shift") }
1079 sub pp_caller { unop(@_, "caller") }
1080 sub pp_reset { unop(@_, "reset") }
1081 sub pp_exit { unop(@_, "exit") }
1082 sub pp_prototype { unop(@_, "prototype") }
1084 sub pp_close { unop(@_, "close") }
1085 sub pp_fileno { unop(@_, "fileno") }
1086 sub pp_umask { unop(@_, "umask") }
1087 sub pp_untie { unop(@_, "untie") }
1088 sub pp_tied { unop(@_, "tied") }
1089 sub pp_dbmclose { unop(@_, "dbmclose") }
1090 sub pp_getc { unop(@_, "getc") }
1091 sub pp_eof { unop(@_, "eof") }
1092 sub pp_tell { unop(@_, "tell") }
1093 sub pp_getsockname { unop(@_, "getsockname") }
1094 sub pp_getpeername { unop(@_, "getpeername") }
1096 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1097 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1098 sub pp_readlink { unop(@_, "readlink") }
1099 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1100 sub pp_readdir { unop(@_, "readdir") }
1101 sub pp_telldir { unop(@_, "telldir") }
1102 sub pp_rewinddir { unop(@_, "rewinddir") }
1103 sub pp_closedir { unop(@_, "closedir") }
1104 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1105 sub pp_localtime { unop(@_, "localtime") }
1106 sub pp_gmtime { unop(@_, "gmtime") }
1107 sub pp_alarm { unop(@_, "alarm") }
1108 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1110 sub pp_dofile { unop(@_, "do") }
1111 sub pp_entereval { unop(@_, "eval") }
1113 sub pp_ghbyname { unop(@_, "gethostbyname") }
1114 sub pp_gnbyname { unop(@_, "getnetbyname") }
1115 sub pp_gpbyname { unop(@_, "getprotobyname") }
1116 sub pp_shostent { unop(@_, "sethostent") }
1117 sub pp_snetent { unop(@_, "setnetent") }
1118 sub pp_sprotoent { unop(@_, "setprotoent") }
1119 sub pp_sservent { unop(@_, "setservent") }
1120 sub pp_gpwnam { unop(@_, "getpwnam") }
1121 sub pp_gpwuid { unop(@_, "getpwuid") }
1122 sub pp_ggrnam { unop(@_, "getgrnam") }
1123 sub pp_ggrgid { unop(@_, "getgrgid") }
1125 sub pp_lock { unop(@_, "lock") }
1130 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1138 if ($op->private & OPpSLICE) {
1139 return $self->maybe_parens_func("delete",
1140 $self->pp_hslice($op->first, 16),
1143 return $self->maybe_parens_func("delete",
1144 $self->pp_helem($op->first, 16),
1152 if (class($op) eq "UNOP" and $op->first->name eq "const"
1153 and $op->first->private & OPpCONST_BARE)
1155 my $name = $self->const_sv($op->first)->PV;
1158 return "require($name)";
1160 $self->unop($op, $cx, "require");
1167 my $kid = $op->first;
1168 if (not null $kid->sibling) {
1169 # XXX Was a here-doc
1170 return $self->dquote($op);
1172 $self->unop(@_, "scalar");
1179 #cluck "curcv was undef" unless $self->{curcv};
1180 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1186 my $kid = $op->first;
1187 if ($kid->name eq "null") {
1189 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1190 my($pre, $post) = @{{"anonlist" => ["[","]"],
1191 "anonhash" => ["{","}"]}->{$kid->name}};
1193 $kid = $kid->first->sibling; # skip pushmark
1194 for (; !null($kid); $kid = $kid->sibling) {
1195 $expr = $self->deparse($kid, 6);
1198 return $pre . join(", ", @exprs) . $post;
1199 } elsif (!null($kid->sibling) and
1200 $kid->sibling->name eq "anoncode") {
1202 $self->deparse_sub($self->padval($kid->sibling->targ));
1203 } elsif ($kid->name eq "pushmark") {
1204 my $sib_name = $kid->sibling->name;
1205 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1206 and not $kid->sibling->flags & OPf_REF)
1208 # The @a in \(@a) isn't in ref context, but only when the
1210 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1211 } elsif ($sib_name eq 'entersub') {
1212 my $text = $self->deparse($kid->sibling, 1);
1213 # Always show parens for \(&func()), but only with -p otherwise
1214 $text = "($text)" if $self->{'parens'}
1215 or $kid->sibling->private & OPpENTERSUB_AMPER;
1220 $self->pfixop($op, $cx, "\\", 20);
1223 sub pp_srefgen { pp_refgen(@_) }
1228 my $kid = $op->first;
1229 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1230 return "<" . $self->deparse($kid, 1) . ">";
1233 # Unary operators that can occur as pseudo-listops inside double quotes
1236 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1238 if ($op->flags & OPf_KIDS) {
1240 # If there's more than one kid, the first is an ex-pushmark.
1241 $kid = $kid->sibling if not null $kid->sibling;
1242 return $self->maybe_parens_unop($name, $kid, $cx);
1244 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1248 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1249 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1250 sub pp_uc { dq_unop(@_, "uc") }
1251 sub pp_lc { dq_unop(@_, "lc") }
1252 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1256 my ($op, $cx, $name) = @_;
1257 if (class($op) eq "PVOP") {
1258 return "$name " . $op->pv;
1259 } elsif (class($op) eq "OP") {
1261 } elsif (class($op) eq "UNOP") {
1262 # Note -- loop exits are actually exempt from the
1263 # looks-like-a-func rule, but a few extra parens won't hurt
1264 return $self->maybe_parens_unop($name, $op->first, $cx);
1268 sub pp_last { loopex(@_, "last") }
1269 sub pp_next { loopex(@_, "next") }
1270 sub pp_redo { loopex(@_, "redo") }
1271 sub pp_goto { loopex(@_, "goto") }
1272 sub pp_dump { loopex(@_, "dump") }
1276 my($op, $cx, $name) = @_;
1277 if (class($op) eq "UNOP") {
1278 # Genuine `-X' filetests are exempt from the LLAFR, but not
1279 # l?stat(); for the sake of clarity, give'em all parens
1280 return $self->maybe_parens_unop($name, $op->first, $cx);
1281 } elsif (class($op) eq "SVOP") {
1282 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1283 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1288 sub pp_lstat { ftst(@_, "lstat") }
1289 sub pp_stat { ftst(@_, "stat") }
1290 sub pp_ftrread { ftst(@_, "-R") }
1291 sub pp_ftrwrite { ftst(@_, "-W") }
1292 sub pp_ftrexec { ftst(@_, "-X") }
1293 sub pp_fteread { ftst(@_, "-r") }
1294 sub pp_ftewrite { ftst(@_, "-r") }
1295 sub pp_fteexec { ftst(@_, "-r") }
1296 sub pp_ftis { ftst(@_, "-e") }
1297 sub pp_fteowned { ftst(@_, "-O") }
1298 sub pp_ftrowned { ftst(@_, "-o") }
1299 sub pp_ftzero { ftst(@_, "-z") }
1300 sub pp_ftsize { ftst(@_, "-s") }
1301 sub pp_ftmtime { ftst(@_, "-M") }
1302 sub pp_ftatime { ftst(@_, "-A") }
1303 sub pp_ftctime { ftst(@_, "-C") }
1304 sub pp_ftsock { ftst(@_, "-S") }
1305 sub pp_ftchr { ftst(@_, "-c") }
1306 sub pp_ftblk { ftst(@_, "-b") }
1307 sub pp_ftfile { ftst(@_, "-f") }
1308 sub pp_ftdir { ftst(@_, "-d") }
1309 sub pp_ftpipe { ftst(@_, "-p") }
1310 sub pp_ftlink { ftst(@_, "-l") }
1311 sub pp_ftsuid { ftst(@_, "-u") }
1312 sub pp_ftsgid { ftst(@_, "-g") }
1313 sub pp_ftsvtx { ftst(@_, "-k") }
1314 sub pp_fttty { ftst(@_, "-t") }
1315 sub pp_fttext { ftst(@_, "-T") }
1316 sub pp_ftbinary { ftst(@_, "-B") }
1318 sub SWAP_CHILDREN () { 1 }
1319 sub ASSIGN () { 2 } # has OP= variant
1325 my $name = $op->name;
1326 if ($name eq "concat" and $op->first->name eq "concat") {
1327 # avoid spurious `=' -- see comment in pp_concat
1330 if ($name eq "null" and class($op) eq "UNOP"
1331 and $op->first->name =~ /^(and|x?or)$/
1332 and null $op->first->sibling)
1334 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1335 # with a null that's used as the common end point of the two
1336 # flows of control. For precedence purposes, ignore it.
1337 # (COND_EXPRs have these too, but we don't bother with
1338 # their associativity).
1339 return assoc_class($op->first);
1341 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1344 # Left associative operators, like `+', for which
1345 # $a + $b + $c is equivalent to ($a + $b) + $c
1348 %left = ('multiply' => 19, 'i_multiply' => 19,
1349 'divide' => 19, 'i_divide' => 19,
1350 'modulo' => 19, 'i_modulo' => 19,
1352 'add' => 18, 'i_add' => 18,
1353 'subtract' => 18, 'i_subtract' => 18,
1355 'left_shift' => 17, 'right_shift' => 17,
1357 'bit_or' => 12, 'bit_xor' => 12,
1359 'or' => 2, 'xor' => 2,
1363 sub deparse_binop_left {
1365 my($op, $left, $prec) = @_;
1366 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1367 and $left{assoc_class($op)} == $left{assoc_class($left)})
1369 return $self->deparse($left, $prec - .00001);
1371 return $self->deparse($left, $prec);
1375 # Right associative operators, like `=', for which
1376 # $a = $b = $c is equivalent to $a = ($b = $c)
1379 %right = ('pow' => 22,
1380 'sassign=' => 7, 'aassign=' => 7,
1381 'multiply=' => 7, 'i_multiply=' => 7,
1382 'divide=' => 7, 'i_divide=' => 7,
1383 'modulo=' => 7, 'i_modulo=' => 7,
1385 'add=' => 7, 'i_add=' => 7,
1386 'subtract=' => 7, 'i_subtract=' => 7,
1388 'left_shift=' => 7, 'right_shift=' => 7,
1390 'bit_or=' => 7, 'bit_xor=' => 7,
1396 sub deparse_binop_right {
1398 my($op, $right, $prec) = @_;
1399 if ($right{assoc_class($op)} && $right{assoc_class($right)}
1400 and $right{assoc_class($op)} == $right{assoc_class($right)})
1402 return $self->deparse($right, $prec - .00001);
1404 return $self->deparse($right, $prec);
1410 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1411 my $left = $op->first;
1412 my $right = $op->last;
1414 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1418 if ($flags & SWAP_CHILDREN) {
1419 ($left, $right) = ($right, $left);
1421 $left = $self->deparse_binop_left($op, $left, $prec);
1422 $right = $self->deparse_binop_right($op, $right, $prec);
1423 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1426 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1427 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1428 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1429 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1430 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1431 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1432 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1433 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1434 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1435 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1436 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1438 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1439 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1440 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1441 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1442 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1444 sub pp_eq { binop(@_, "==", 14) }
1445 sub pp_ne { binop(@_, "!=", 14) }
1446 sub pp_lt { binop(@_, "<", 15) }
1447 sub pp_gt { binop(@_, ">", 15) }
1448 sub pp_ge { binop(@_, ">=", 15) }
1449 sub pp_le { binop(@_, "<=", 15) }
1450 sub pp_ncmp { binop(@_, "<=>", 14) }
1451 sub pp_i_eq { binop(@_, "==", 14) }
1452 sub pp_i_ne { binop(@_, "!=", 14) }
1453 sub pp_i_lt { binop(@_, "<", 15) }
1454 sub pp_i_gt { binop(@_, ">", 15) }
1455 sub pp_i_ge { binop(@_, ">=", 15) }
1456 sub pp_i_le { binop(@_, "<=", 15) }
1457 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1459 sub pp_seq { binop(@_, "eq", 14) }
1460 sub pp_sne { binop(@_, "ne", 14) }
1461 sub pp_slt { binop(@_, "lt", 15) }
1462 sub pp_sgt { binop(@_, "gt", 15) }
1463 sub pp_sge { binop(@_, "ge", 15) }
1464 sub pp_sle { binop(@_, "le", 15) }
1465 sub pp_scmp { binop(@_, "cmp", 14) }
1467 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1468 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1470 # `.' is special because concats-of-concats are optimized to save copying
1471 # by making all but the first concat stacked. The effect is as if the
1472 # programmer had written `($a . $b) .= $c', except legal.
1473 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1477 my $left = $op->first;
1478 my $right = $op->last;
1481 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1485 $left = $self->deparse_binop_left($op, $left, $prec);
1486 $right = $self->deparse_binop_right($op, $right, $prec);
1487 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1490 # `x' is weird when the left arg is a list
1494 my $left = $op->first;
1495 my $right = $op->last;
1498 if ($op->flags & OPf_STACKED) {
1502 if (null($right)) { # list repeat; count is inside left-side ex-list
1503 my $kid = $left->first->sibling; # skip pushmark
1505 for (; !null($kid->sibling); $kid = $kid->sibling) {
1506 push @exprs, $self->deparse($kid, 6);
1509 $left = "(" . join(", ", @exprs). ")";
1511 $left = $self->deparse_binop_left($op, $left, $prec);
1513 $right = $self->deparse_binop_right($op, $right, $prec);
1514 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1519 my ($op, $cx, $type) = @_;
1520 my $left = $op->first;
1521 my $right = $left->sibling;
1522 $left = $self->deparse($left, 9);
1523 $right = $self->deparse($right, 9);
1524 return $self->maybe_parens("$left $type $right", $cx, 9);
1530 my $flip = $op->first;
1531 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1532 return $self->range($flip->first, $cx, $type);
1535 # one-line while/until is handled in pp_leave
1539 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1540 my $left = $op->first;
1541 my $right = $op->first->sibling;
1542 if ($cx == 0 and is_scope($right) and $blockname
1543 and $self->{'expand'} < 7)
1545 $left = $self->deparse($left, 1);
1546 $right = $self->deparse($right, 0);
1547 return "$blockname ($left) {\n\t$right\n\b}\cK";
1548 } elsif ($cx == 0 and $blockname and not $self->{'parens'}
1549 and $self->{'expand'} < 7) { # $b if $a
1550 $right = $self->deparse($right, 1);
1551 $left = $self->deparse($left, 1);
1552 return "$right $blockname $left";
1553 } elsif ($cx > $lowprec and $highop) { # $a && $b
1554 $left = $self->deparse_binop_left($op, $left, $highprec);
1555 $right = $self->deparse_binop_right($op, $right, $highprec);
1556 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1557 } else { # $a and $b
1558 $left = $self->deparse_binop_left($op, $left, $lowprec);
1559 $right = $self->deparse_binop_right($op, $right, $lowprec);
1560 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1564 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1565 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1567 # xor is syntactically a logop, but it's really a binop (contrary to
1568 # old versions of opcode.pl). Syntax is what matters here.
1569 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1573 my ($op, $cx, $opname) = @_;
1574 my $left = $op->first;
1575 my $right = $op->first->sibling->first; # skip sassign
1576 $left = $self->deparse($left, 7);
1577 $right = $self->deparse($right, 7);
1578 return $self->maybe_parens("$left $opname $right", $cx, 7);
1581 sub pp_andassign { logassignop(@_, "&&=") }
1582 sub pp_orassign { logassignop(@_, "||=") }
1586 my($op, $cx, $name) = @_;
1588 my $parens = ($cx >= 5) || $self->{'parens'};
1589 my $kid = $op->first->sibling;
1590 return $name if null $kid;
1591 my $first = $self->deparse($kid, 6);
1592 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1593 push @exprs, $first;
1594 $kid = $kid->sibling;
1595 for (; !null($kid); $kid = $kid->sibling) {
1596 push @exprs, $self->deparse($kid, 6);
1599 return "$name(" . join(", ", @exprs) . ")";
1601 return "$name " . join(", ", @exprs);
1605 sub pp_bless { listop(@_, "bless") }
1606 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
1607 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1608 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1609 sub pp_index { maybe_targmy(@_, \&listop, "index") }
1610 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
1611 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
1612 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1613 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
1614 sub pp_unpack { listop(@_, "unpack") }
1615 sub pp_pack { listop(@_, "pack") }
1616 sub pp_join { maybe_targmy(@_, \&listop, "join") }
1617 sub pp_splice { listop(@_, "splice") }
1618 sub pp_push { maybe_targmy(@_, \&listop, "push") }
1619 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
1620 sub pp_reverse { listop(@_, "reverse") }
1621 sub pp_warn { listop(@_, "warn") }
1622 sub pp_die { listop(@_, "die") }
1623 # Actually, return is exempt from the LLAFR (see examples in this very
1624 # module!), but for consistency's sake, ignore that fact
1625 sub pp_return { listop(@_, "return") }
1626 sub pp_open { listop(@_, "open") }
1627 sub pp_pipe_op { listop(@_, "pipe") }
1628 sub pp_tie { listop(@_, "tie") }
1629 sub pp_binmode { listop(@_, "binmode") }
1630 sub pp_dbmopen { listop(@_, "dbmopen") }
1631 sub pp_sselect { listop(@_, "select") }
1632 sub pp_select { listop(@_, "select") }
1633 sub pp_read { listop(@_, "read") }
1634 sub pp_sysopen { listop(@_, "sysopen") }
1635 sub pp_sysseek { listop(@_, "sysseek") }
1636 sub pp_sysread { listop(@_, "sysread") }
1637 sub pp_syswrite { listop(@_, "syswrite") }
1638 sub pp_send { listop(@_, "send") }
1639 sub pp_recv { listop(@_, "recv") }
1640 sub pp_seek { listop(@_, "seek") }
1641 sub pp_fcntl { listop(@_, "fcntl") }
1642 sub pp_ioctl { listop(@_, "ioctl") }
1643 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
1644 sub pp_socket { listop(@_, "socket") }
1645 sub pp_sockpair { listop(@_, "sockpair") }
1646 sub pp_bind { listop(@_, "bind") }
1647 sub pp_connect { listop(@_, "connect") }
1648 sub pp_listen { listop(@_, "listen") }
1649 sub pp_accept { listop(@_, "accept") }
1650 sub pp_shutdown { listop(@_, "shutdown") }
1651 sub pp_gsockopt { listop(@_, "getsockopt") }
1652 sub pp_ssockopt { listop(@_, "setsockopt") }
1653 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
1654 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
1655 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
1656 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
1657 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
1658 sub pp_link { maybe_targmy(@_, \&listop, "link") }
1659 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
1660 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
1661 sub pp_open_dir { listop(@_, "opendir") }
1662 sub pp_seekdir { listop(@_, "seekdir") }
1663 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
1664 sub pp_system { maybe_targmy(@_, \&listop, "system") }
1665 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
1666 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
1667 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
1668 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
1669 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
1670 sub pp_shmget { listop(@_, "shmget") }
1671 sub pp_shmctl { listop(@_, "shmctl") }
1672 sub pp_shmread { listop(@_, "shmread") }
1673 sub pp_shmwrite { listop(@_, "shmwrite") }
1674 sub pp_msgget { listop(@_, "msgget") }
1675 sub pp_msgctl { listop(@_, "msgctl") }
1676 sub pp_msgsnd { listop(@_, "msgsnd") }
1677 sub pp_msgrcv { listop(@_, "msgrcv") }
1678 sub pp_semget { listop(@_, "semget") }
1679 sub pp_semctl { listop(@_, "semctl") }
1680 sub pp_semop { listop(@_, "semop") }
1681 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1682 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1683 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1684 sub pp_gsbyname { listop(@_, "getservbyname") }
1685 sub pp_gsbyport { listop(@_, "getservbyport") }
1686 sub pp_syscall { listop(@_, "syscall") }
1691 my $text = $self->dq($op->first->sibling); # skip pushmark
1692 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1693 or $text =~ /[<>]/) {
1694 return 'glob(' . single_delim('qq', '"', $text) . ')';
1696 return '<' . $text . '>';
1700 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1701 # be a filehandle. This could probably be better fixed in the core
1702 # by moving the GV lookup into ck_truc.
1708 my $parens = ($cx >= 5) || $self->{'parens'};
1709 my $kid = $op->first->sibling;
1711 if ($op->flags & OPf_SPECIAL) {
1712 # $kid is an OP_CONST
1713 $fh = $self->const_sv($kid)->PV;
1715 $fh = $self->deparse($kid, 6);
1716 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1718 my $len = $self->deparse($kid->sibling, 6);
1720 return "truncate($fh, $len)";
1722 return "truncate $fh, $len";
1728 my($op, $cx, $name) = @_;
1730 my $kid = $op->first->sibling;
1732 if ($op->flags & OPf_STACKED) {
1734 $indir = $indir->first; # skip rv2gv
1735 if (is_scope($indir)) {
1736 $indir = "{" . $self->deparse($indir, 0) . "}";
1738 $indir = $self->deparse($indir, 24);
1740 $indir = $indir . " ";
1741 $kid = $kid->sibling;
1743 for (; !null($kid); $kid = $kid->sibling) {
1744 $expr = $self->deparse($kid, 6);
1747 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
1751 sub pp_prtf { indirop(@_, "printf") }
1752 sub pp_print { indirop(@_, "print") }
1753 sub pp_sort { indirop(@_, "sort") }
1757 my($op, $cx, $name) = @_;
1759 my $kid = $op->first; # this is the (map|grep)start
1760 $kid = $kid->first->sibling; # skip a pushmark
1761 my $code = $kid->first; # skip a null
1762 if (is_scope $code) {
1763 $code = "{" . $self->deparse($code, 0) . "} ";
1765 $code = $self->deparse($code, 24) . ", ";
1767 $kid = $kid->sibling;
1768 for (; !null($kid); $kid = $kid->sibling) {
1769 $expr = $self->deparse($kid, 6);
1770 push @exprs, $expr if $expr;
1772 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1775 sub pp_mapwhile { mapop(@_, "map") }
1776 sub pp_grepwhile { mapop(@_, "grep") }
1782 my $kid = $op->first->sibling; # skip pushmark
1784 my $local = "either"; # could be local(...) or my(...)
1785 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1786 # This assumes that no other private flags equal 128, and that
1787 # OPs that store things other than flags in their op_private,
1788 # like OP_AELEMFAST, won't be immediate children of a list.
1789 unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
1791 $local = ""; # or not
1794 if ($lop->name =~ /^pad[ash]v$/) { # my()
1795 ($local = "", last) if $local eq "local";
1797 } elsif ($lop->name ne "undef") { # local()
1798 ($local = "", last) if $local eq "my";
1802 $local = "" if $local eq "either"; # no point if it's all undefs
1803 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
1804 for (; !null($kid); $kid = $kid->sibling) {
1806 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
1811 $self->{'avoid_local'}{$$lop}++;
1812 $expr = $self->deparse($kid, 6);
1813 delete $self->{'avoid_local'}{$$lop};
1815 $expr = $self->deparse($kid, 6);
1820 return "$local(" . join(", ", @exprs) . ")";
1822 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1826 sub is_ifelse_cont {
1828 return ($op->name eq "null" and class($op) eq "UNOP"
1829 and $op->first->name =~ /^(and|cond_expr)$/
1830 and is_scope($op->first->first->sibling));
1836 my $cond = $op->first;
1837 my $true = $cond->sibling;
1838 my $false = $true->sibling;
1839 my $cuddle = $self->{'cuddle'};
1840 unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
1841 (is_scope($false) || is_ifelse_cont($false))
1842 and $self->{'expand'} < 7) {
1843 $cond = $self->deparse($cond, 8);
1844 $true = $self->deparse($true, 8);
1845 $false = $self->deparse($false, 8);
1846 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1849 $cond = $self->deparse($cond, 1);
1850 $true = $self->deparse($true, 0);
1851 my $head = "if ($cond) {\n\t$true\n\b}";
1853 while (!null($false) and is_ifelse_cont($false)) {
1854 my $newop = $false->first;
1855 my $newcond = $newop->first;
1856 my $newtrue = $newcond->sibling;
1857 $false = $newtrue->sibling; # last in chain is OP_AND => no else
1858 $newcond = $self->deparse($newcond, 1);
1859 $newtrue = $self->deparse($newtrue, 0);
1860 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1862 if (!null($false)) {
1863 $false = $cuddle . "else {\n\t" .
1864 $self->deparse($false, 0) . "\n\b}\cK";
1868 return $head . join($cuddle, "", @elsifs) . $false;
1873 my($op, $cx, $init) = @_;
1874 my $enter = $op->first;
1875 my $kid = $enter->sibling;
1876 local($self->{'curstash'}) = $self->{'curstash'};
1881 if ($kid->name eq "lineseq") { # bare or infinite loop
1882 if (is_state $kid->last) { # infinite
1883 $head = "for (;;) "; # shorter than while (1)
1889 } elsif ($enter->name eq "enteriter") { # foreach
1890 my $ary = $enter->first->sibling; # first was pushmark
1891 my $var = $ary->sibling;
1892 if ($enter->flags & OPf_STACKED
1893 and not null $ary->first->sibling->sibling)
1895 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1896 $self->deparse($ary->first->sibling->sibling, 9);
1898 $ary = $self->deparse($ary, 1);
1901 if ($enter->flags & OPf_SPECIAL) { # thread special var
1902 $var = $self->pp_threadsv($enter, 1);
1903 } else { # regular my() variable
1904 $var = $self->pp_padsv($enter, 1);
1905 if ($self->padname_sv($enter->targ)->IVX ==
1906 $kid->first->first->sibling->last->cop_seq)
1908 # If the scope of this variable closes at the last
1909 # statement of the loop, it must have been
1911 $var = "my " . $var;
1914 } elsif ($var->name eq "rv2gv") {
1915 $var = $self->pp_rv2sv($var, 1);
1916 } elsif ($var->name eq "gv") {
1917 $var = "\$" . $self->deparse($var, 1);
1919 $head = "foreach $var ($ary) ";
1920 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1921 } elsif ($kid->name eq "null") { # while/until
1923 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
1924 $cond = $self->deparse($kid->first, 1);
1925 $head = "$name ($cond) ";
1926 $body = $kid->first->sibling;
1927 } elsif ($kid->name eq "stub") { # bare and empty
1928 return "{;}"; # {} could be a hashref
1930 # If there isn't a continue block, then the next pointer for the loop
1931 # will point to the unstack, which is kid's penultimate child, except
1932 # in a bare loop, when it will point to the leaveloop. When neither of
1933 # these conditions hold, then the third-to-last child in the continue
1934 # block (or the last in a bare loop).
1935 my $cont_start = $enter->nextop;
1937 if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) {
1939 $cont = $body->last;
1941 $cont = $body->first;
1942 while (!null($cont->sibling->sibling->sibling)) {
1943 $cont = $cont->sibling;
1946 my $state = $body->first;
1947 my $cuddle = $self->{'cuddle'};
1949 for (; $$state != $$cont; $state = $state->sibling) {
1950 push @states, $state;
1952 $body = $self->lineseq(@states);
1953 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
1954 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
1957 $cont = $cuddle . "continue {\n\t" .
1958 $self->deparse($cont, 0) . "\n\b}\cK";
1961 return "" if !defined $body;
1963 $body = $self->deparse($body, 0);
1965 return $head . "{\n\t" . $body . "\n\b}" . $cont;
1968 sub pp_leaveloop { loop_common(@_, "") }
1973 my $init = $self->deparse($op, 1);
1974 return $self->loop_common($op->sibling, $cx, $init);
1979 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
1982 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
1983 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
1988 if (class($op) eq "OP") {
1990 return $self->{'ex_const'} if $op->targ == OP_CONST;
1991 } elsif ($op->first->name eq "pushmark") {
1992 return $self->pp_list($op, $cx);
1993 } elsif ($op->first->name eq "enter") {
1994 return $self->pp_leave($op, $cx);
1995 } elsif ($op->targ == OP_STRINGIFY) {
1996 return $self->dquote($op, $cx);
1997 } elsif (!null($op->first->sibling) and
1998 $op->first->sibling->name eq "readline" and
1999 $op->first->sibling->flags & OPf_STACKED) {
2000 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2001 . $self->deparse($op->first->sibling, 7),
2003 } elsif (!null($op->first->sibling) and
2004 $op->first->sibling->name eq "trans" and
2005 $op->first->sibling->flags & OPf_STACKED) {
2006 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2007 . $self->deparse($op->first->sibling, 20),
2010 return $self->deparse($op->first, $cx);
2017 return $self->padname_sv($targ)->PVX;
2023 return substr($self->padname($op->targ), 1); # skip $/@/%
2029 return $self->maybe_my($op, $cx, $self->padname($op->targ));
2032 sub pp_padav { pp_padsv(@_) }
2033 sub pp_padhv { pp_padsv(@_) }
2038 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2039 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2040 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2047 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
2053 if (class($op) eq "PADOP") {
2054 return $self->padval($op->padix);
2055 } else { # class($op) eq "SVOP"
2063 my $gv = $self->gv_or_padgv($op);
2064 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv));
2070 my $gv = $self->gv_or_padgv($op);
2071 return $self->gv_name($gv);
2077 my $gv = $self->gv_or_padgv($op);
2078 return "\$" . $self->gv_name($gv) . "[" .
2079 ($op->private + $self->{'arybase'}) . "]";
2084 my($op, $cx, $type) = @_;
2085 my $kid = $op->first;
2086 my $str = $self->deparse($kid, 0);
2087 return $type . (is_scalar($kid) ? $str : "{$str}");
2090 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2091 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2092 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2098 if ($op->first->name eq "padav") {
2099 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2101 return $self->maybe_local($op, $cx,
2102 $self->rv2x($op->first, $cx, '$#'));
2106 # skip down to the old, ex-rv2cv
2107 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
2112 my $kid = $op->first;
2113 if ($kid->name eq "const") { # constant list
2114 my $av = $self->const_sv($kid);
2115 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2117 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2121 sub is_subscriptable {
2123 if ($op->name =~ /^[ahg]elem/) {
2125 } elsif ($op->name eq "entersub") {
2126 my $kid = $op->first;
2127 return 0 unless null $kid->sibling;
2129 $kid = $kid->sibling until null $kid->sibling;
2130 return 0 if is_scope($kid);
2132 return 0 if $kid->name eq "gv";
2133 return 0 if is_scalar($kid);
2134 return is_subscriptable($kid);
2142 my ($op, $cx, $left, $right, $padname) = @_;
2143 my($array, $idx) = ($op->first, $op->first->sibling);
2144 unless ($array->name eq $padname) { # Maybe this has been fixed
2145 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2147 if ($array->name eq $padname) {
2148 $array = $self->padany($array);
2149 } elsif (is_scope($array)) { # ${expr}[0]
2150 $array = "{" . $self->deparse($array, 0) . "}";
2151 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2152 $array = $self->deparse($array, 24);
2154 # $x[20][3]{hi} or expr->[20]
2155 my $arrow = is_subscriptable($array) ? "" : "->";
2156 return $self->deparse($array, 24) . $arrow .
2157 $left . $self->deparse($idx, 1) . $right;
2159 $idx = $self->deparse($idx, 1);
2161 # Outer parens in an array index will confuse perl
2162 # if we're interpolating in a regular expression, i.e.
2163 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2165 # If $self->{parens}, then an initial '(' will
2166 # definitely be paired with a final ')'. If
2167 # !$self->{parens}, the misleading parens won't
2168 # have been added in the first place.
2170 # [You might think that we could get "(...)...(...)"
2171 # where the initial and final parens do not match
2172 # each other. But we can't, because the above would
2173 # only happen if there's an infix binop between the
2174 # two pairs of parens, and *that* means that the whole
2175 # expression would be parenthesized as well.]
2177 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2179 return "\$" . $array . $left . $idx . $right;
2182 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2183 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2188 my($glob, $part) = ($op->first, $op->last);
2189 $glob = $glob->first; # skip rv2gv
2190 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2191 my $scope = is_scope($glob);
2192 $glob = $self->deparse($glob, 0);
2193 $part = $self->deparse($part, 1);
2194 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2199 my ($op, $cx, $left, $right, $regname, $padname) = @_;
2201 my(@elems, $kid, $array, $list);
2202 if (class($op) eq "LISTOP") {
2204 } else { # ex-hslice inside delete()
2205 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2209 $array = $array->first
2210 if $array->name eq $regname or $array->name eq "null";
2211 if (is_scope($array)) {
2212 $array = "{" . $self->deparse($array, 0) . "}";
2213 } elsif ($array->name eq $padname) {
2214 $array = $self->padany($array);
2216 $array = $self->deparse($array, 24);
2218 $kid = $op->first->sibling; # skip pushmark
2219 if ($kid->name eq "list") {
2220 $kid = $kid->first->sibling; # skip list, pushmark
2221 for (; !null $kid; $kid = $kid->sibling) {
2222 push @elems, $self->deparse($kid, 6);
2224 $list = join(", ", @elems);
2226 $list = $self->deparse($kid, 1);
2228 return "\@" . $array . $left . $list . $right;
2231 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2232 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2237 my $idx = $op->first;
2238 my $list = $op->last;
2240 $list = $self->deparse($list, 1);
2241 $idx = $self->deparse($idx, 1);
2242 return "($list)" . "[$idx]";
2247 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2252 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2258 my $kid = $op->first->sibling; # skip pushmark
2259 my($meth, $obj, @exprs);
2260 if ($kid->name eq "list" and want_list $kid) {
2261 # When an indirect object isn't a bareword but the args are in
2262 # parens, the parens aren't part of the method syntax (the LLAFR
2263 # doesn't apply), but they make a list with OPf_PARENS set that
2264 # doesn't get flattened by the append_elem that adds the method,
2265 # making a (object, arg1, arg2, ...) list where the object
2266 # usually is. This can be distinguished from
2267 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2268 # object) because in the later the list is in scalar context
2269 # as the left side of -> always is, while in the former
2270 # the list is in list context as method arguments always are.
2271 # (Good thing there aren't method prototypes!)
2272 $meth = $kid->sibling;
2273 $kid = $kid->first->sibling; # skip pushmark
2275 $kid = $kid->sibling;
2276 for (; not null $kid; $kid = $kid->sibling) {
2277 push @exprs, $self->deparse($kid, 6);
2281 $kid = $kid->sibling;
2282 for (; not null $kid->sibling; $kid = $kid->sibling) {
2283 push @exprs, $self->deparse($kid, 6);
2287 $obj = $self->deparse($obj, 24);
2288 if ($meth->name eq "method_named") {
2289 $meth = $self->const_sv($meth)->PV;
2291 $meth = $meth->first;
2292 if ($meth->name eq "const") {
2293 # As of 5.005_58, this case is probably obsoleted by the
2294 # method_named case above
2295 $meth = $self->const_sv($meth)->PV; # needs to be bare
2297 $meth = $self->deparse($meth, 1);
2300 my $args = join(", ", @exprs);
2301 $kid = $obj . "->" . $meth;
2303 return $kid . "(" . $args . ")"; # parens mandatory
2309 # returns "&" if the prototype doesn't match the args,
2310 # or ("", $args_after_prototype_demunging) if it does.
2313 my($proto, @args) = @_;
2317 # An unbackslashed @ or % gobbles up the rest of the args
2318 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2320 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2323 return "&" if @args;
2324 } elsif ($chr eq ";") {
2326 } elsif ($chr eq "@" or $chr eq "%") {
2327 push @reals, map($self->deparse($_, 6), @args);
2333 if (want_scalar $arg) {
2334 push @reals, $self->deparse($arg, 6);
2338 } elsif ($chr eq "&") {
2339 if ($arg->name =~ /^(s?refgen|undef)$/) {
2340 push @reals, $self->deparse($arg, 6);
2344 } elsif ($chr eq "*") {
2345 if ($arg->name =~ /^s?refgen$/
2346 and $arg->first->first->name eq "rv2gv")
2348 $real = $arg->first->first; # skip refgen, null
2349 if ($real->first->name eq "gv") {
2350 push @reals, $self->deparse($real, 6);
2352 push @reals, $self->deparse($real->first, 6);
2357 } elsif (substr($chr, 0, 1) eq "\\") {
2358 $chr = substr($chr, 1);
2359 if ($arg->name =~ /^s?refgen$/ and
2360 !null($real = $arg->first) and
2361 ($chr eq "\$" && is_scalar($real->first)
2363 && $real->first->sibling->name
2366 && $real->first->sibling->name
2368 #or ($chr eq "&" # This doesn't work
2369 # && $real->first->name eq "rv2cv")
2371 && $real->first->name eq "rv2gv")))
2373 push @reals, $self->deparse($real, 6);
2380 return "&" if $proto and !$doneok; # too few args and no `;'
2381 return "&" if @args; # too many args
2382 return ("", join ", ", @reals);
2388 return $self->method($op, $cx) unless null $op->first->sibling;
2392 if ($op->flags & OPf_SPECIAL) {
2394 } elsif ($op->private & OPpENTERSUB_AMPER) {
2398 $kid = $kid->first->sibling; # skip ex-list, pushmark
2399 for (; not null $kid->sibling; $kid = $kid->sibling) {
2404 if (is_scope($kid)) {
2406 $kid = "{" . $self->deparse($kid, 0) . "}";
2407 } elsif ($kid->first->name eq "gv") {
2408 my $gv = $self->gv_or_padgv($kid->first);
2409 if (class($gv->CV) ne "SPECIAL") {
2410 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2412 $simple = 1; # only calls of named functions can be prototyped
2413 $kid = $self->deparse($kid, 24);
2414 } elsif (is_scalar $kid->first) {
2416 $kid = $self->deparse($kid, 24);
2419 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2420 $kid = $self->deparse($kid, 24) . $arrow;
2423 # Doesn't matter how many prototypes there are, if
2424 # they haven't happened yet!
2425 my $declared = exists $self->{'subs_declared'}{$kid};
2428 if ($declared and defined $proto and not $amper) {
2429 ($amper, $args) = $self->check_proto($proto, @exprs);
2430 if ($amper eq "&") {
2431 $args = join(", ", map($self->deparse($_, 6), @exprs));
2434 $args = join(", ", map($self->deparse($_, 6), @exprs));
2436 if ($prefix or $amper) {
2437 if ($op->flags & OPf_STACKED) {
2438 return $prefix . $amper . $kid . "(" . $args . ")";
2440 return $prefix . $amper. $kid;
2444 return "$kid(" . $args . ")";
2445 } elsif (defined $proto and $proto eq "") {
2447 } elsif (defined $proto and $proto eq "\$") {
2448 return $self->maybe_parens_func($kid, $args, $cx, 16);
2449 } elsif (defined($proto) && $proto or $simple) {
2450 return $self->maybe_parens_func($kid, $args, $cx, 5);
2452 return "$kid(" . $args . ")";
2457 sub pp_enterwrite { unop(@_, "write") }
2459 # escape things that cause interpolation in double quotes,
2460 # but not character escapes
2463 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2467 # the same, but treat $|, $), and $ at the end of the string differently
2470 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2471 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2475 # character escapes, but not delimiters that might need to be escaped
2476 sub escape_str { # ASCII
2479 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2485 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2486 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2490 # Don't do this for regexen
2493 $str =~ s/\\/\\\\/g;
2497 # Remove backslashes which precede literal control characters,
2498 # to avoid creating ambiguity when we escape the latter.
2502 # the insane complexity here is due to the behaviour of "\c\"
2503 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
2507 sub balanced_delim {
2509 my @str = split //, $str;
2510 my($ar, $open, $close, $fail, $c, $cnt);
2511 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2512 ($open, $close) = @$ar;
2513 $fail = 0; $cnt = 0;
2517 } elsif ($c eq $close) {
2526 $fail = 1 if $cnt != 0;
2527 return ($open, "$open$str$close") if not $fail;
2533 my($q, $default, $str) = @_;
2534 return "$default$str$default" if $default and index($str, $default) == -1;
2535 my($succeed, $delim);
2536 ($succeed, $str) = balanced_delim($str);
2537 return "$q$str" if $succeed;
2538 for $delim ('/', '"', '#') {
2539 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2542 $str =~ s/$default/\\$default/g;
2543 return "$default$str$default";
2552 if (class($sv) eq "SPECIAL") {
2553 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2554 } elsif (class($sv) eq "NULL") {
2556 } elsif ($sv->FLAGS & SVf_IOK) {
2557 return $sv->int_value;
2558 } elsif ($sv->FLAGS & SVf_NOK) {
2560 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
2561 return "\\(" . const($sv->RV) . ")"; # constant folded
2564 if ($str =~ /[^ -~]/) { # ASCII for non-printing
2565 return single_delim("qq", '"', uninterp escape_str unback $str);
2567 return single_delim("q", "'", unback $str);
2576 # the constant could be in the pad (under useithreads)
2577 $sv = $self->padval($op->targ) unless $$sv;
2584 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2585 # return $self->const_sv($op)->PV;
2587 my $sv = $self->const_sv($op);
2588 # return const($sv);
2589 if ($op->private & OPpCONST_ARYBASE) {
2593 return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
2599 my $type = $op->name;
2600 if ($type eq "const") {
2601 return uninterp(escape_str(unback($self->const_sv($op)->PV)));
2602 } elsif ($type eq "concat") {
2603 my $first = $self->dq($op->first);
2604 my $last = $self->dq($op->last);
2605 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2606 if ($last =~ /^[{\[\w]/) {
2607 $first =~ s/([%\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2609 return $first . $last;
2610 } elsif ($type eq "uc") {
2611 return '\U' . $self->dq($op->first->sibling) . '\E';
2612 } elsif ($type eq "lc") {
2613 return '\L' . $self->dq($op->first->sibling) . '\E';
2614 } elsif ($type eq "ucfirst") {
2615 return '\u' . $self->dq($op->first->sibling);
2616 } elsif ($type eq "lcfirst") {
2617 return '\l' . $self->dq($op->first->sibling);
2618 } elsif ($type eq "quotemeta") {
2619 return '\Q' . $self->dq($op->first->sibling) . '\E';
2620 } elsif ($type eq "join") {
2621 return $self->deparse($op->last, 26); # was join($", @ary)
2623 return $self->deparse($op, 26);
2631 return single_delim("qx", '`', $self->dq($op->first->sibling));
2637 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2638 return $self->deparse($kid, $cx) if $self->{'unquote'};
2639 $self->maybe_targmy($kid, $cx,
2640 sub {single_delim("qq", '"', $self->dq($_[1]))});
2643 # OP_STRINGIFY is a listop, but it only ever has one arg
2644 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2646 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2647 # note that tr(from)/to/ is OK, but not tr/from/(to)
2649 my($from, $to) = @_;
2650 my($succeed, $delim);
2651 if ($from !~ m[/] and $to !~ m[/]) {
2652 return "/$from/$to/";
2653 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2654 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2657 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2658 return "$from$delim$to$delim" if index($to, $delim) == -1;
2661 return "$from/$to/";
2664 for $delim ('/', '"', '#') { # note no '
2665 return "$delim$from$delim$to$delim"
2666 if index($to . $from, $delim) == -1;
2668 $from =~ s[/][\\/]g;
2670 return "/$from/$to/";
2676 if ($n == ord '\\') {
2678 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2680 } elsif ($n == ord "\a") {
2682 } elsif ($n == ord "\b") {
2684 } elsif ($n == ord "\t") {
2686 } elsif ($n == ord "\n") {
2688 } elsif ($n == ord "\e") {
2690 } elsif ($n == ord "\f") {
2692 } elsif ($n == ord "\r") {
2694 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2695 return '\\c' . chr(ord("@") + $n);
2697 # return '\x' . sprintf("%02x", $n);
2698 return '\\' . sprintf("%03o", $n);
2704 my($str, $c, $tr) = ("");
2705 for ($c = 0; $c < @chars; $c++) {
2708 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2709 $chars[$c + 2] == $tr + 2)
2711 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
2714 $str .= pchr($chars[$c]);
2720 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
2723 sub tr_decode_byte {
2724 my($table, $flags) = @_;
2725 my(@table) = unpack("s256", $table);
2726 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2727 if ($table[ord "-"] != -1 and
2728 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2730 $tr = $table[ord "-"];
2731 $table[ord "-"] = -1;
2735 } else { # -2 ==> delete
2739 for ($c = 0; $c < 256; $c++) {
2742 push @from, $c; push @to, $tr;
2743 } elsif ($tr == -2) {
2747 @from = (@from, @delfrom);
2748 if ($flags & OPpTRANS_COMPLEMENT) {
2751 @from{@from} = (1) x @from;
2752 for ($c = 0; $c < 256; $c++) {
2753 push @newfrom, $c unless $from{$c};
2757 unless ($flags & OPpTRANS_DELETE || !@to) {
2758 pop @to while $#to and $to[$#to] == $to[$#to -1];
2761 $from = collapse(@from);
2762 $to = collapse(@to);
2763 $from .= "-" if $delhyphen;
2764 return ($from, $to);
2769 if ($x == ord "-") {
2776 # XXX This doesn't yet handle all cases correctly either
2778 sub tr_decode_utf8 {
2779 my($swash_hv, $flags) = @_;
2780 my %swash = $swash_hv->ARRAY;
2782 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
2783 my $none = $swash{"NONE"}->IV;
2784 my $extra = $none + 1;
2785 my(@from, @delfrom, @to);
2787 foreach $line (split /\n/, $swash{'LIST'}->PV) {
2788 my($min, $max, $result) = split(/\t/, $line);
2795 $result = hex $result;
2796 if ($result == $extra) {
2797 push @delfrom, [$min, $max];
2799 push @from, [$min, $max];
2800 push @to, [$result, $result + $max - $min];
2803 for my $i (0 .. $#from) {
2804 if ($from[$i][0] == ord '-') {
2805 unshift @from, splice(@from, $i, 1);
2806 unshift @to, splice(@to, $i, 1);
2808 } elsif ($from[$i][1] == ord '-') {
2811 unshift @from, ord '-';
2812 unshift @to, ord '-';
2816 for my $i (0 .. $#delfrom) {
2817 if ($delfrom[$i][0] == ord '-') {
2818 push @delfrom, splice(@delfrom, $i, 1);
2820 } elsif ($delfrom[$i][1] == ord '-') {
2822 push @delfrom, ord '-';
2826 if (defined $final and $to[$#to][1] != $final) {
2827 push @to, [$final, $final];
2829 push @from, @delfrom;
2830 if ($flags & OPpTRANS_COMPLEMENT) {
2833 for my $i (0 .. $#from) {
2834 push @newfrom, [$next, $from[$i][0] - 1];
2835 $next = $from[$i][1] + 1;
2838 for my $range (@newfrom) {
2839 if ($range->[0] <= $range->[1]) {
2844 my($from, $to, $diff);
2845 for my $chunk (@from) {
2846 $diff = $chunk->[1] - $chunk->[0];
2848 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2849 } elsif ($diff == 1) {
2850 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2852 $from .= tr_chr($chunk->[0]);
2855 for my $chunk (@to) {
2856 $diff = $chunk->[1] - $chunk->[0];
2858 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2859 } elsif ($diff == 1) {
2860 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2862 $to .= tr_chr($chunk->[0]);
2865 #$final = sprintf("%04x", $final) if defined $final;
2866 #$none = sprintf("%04x", $none) if defined $none;
2867 #$extra = sprintf("%04x", $extra) if defined $extra;
2868 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
2869 #print STDERR $swash{'LIST'}->PV;
2870 return (escape_str($from), escape_str($to));
2877 if (class($op) eq "PVOP") {
2878 ($from, $to) = tr_decode_byte($op->pv, $op->private);
2879 } else { # class($op) eq "SVOP"
2880 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
2883 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
2884 $flags .= "d" if $op->private & OPpTRANS_DELETE;
2885 $to = "" if $from eq $to and $flags eq "";
2886 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2887 return "tr" . double_delim($from, $to) . $flags;
2890 # Like dq(), but different
2894 my $type = $op->name;
2895 if ($type eq "const") {
2896 return re_uninterp(escape_str(re_unback($self->const_sv($op)->PV)));
2897 } elsif ($type eq "concat") {
2898 my $first = $self->re_dq($op->first);
2899 my $last = $self->re_dq($op->last);
2900 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2901 if ($last =~ /^[{\[\w]/) {
2902 $first =~ s/([%\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2904 return $first . $last;
2905 } elsif ($type eq "uc") {
2906 return '\U' . $self->re_dq($op->first->sibling) . '\E';
2907 } elsif ($type eq "lc") {
2908 return '\L' . $self->re_dq($op->first->sibling) . '\E';
2909 } elsif ($type eq "ucfirst") {
2910 return '\u' . $self->re_dq($op->first->sibling);
2911 } elsif ($type eq "lcfirst") {
2912 return '\l' . $self->re_dq($op->first->sibling);
2913 } elsif ($type eq "quotemeta") {
2914 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2915 } elsif ($type eq "join") {
2916 return $self->deparse($op->last, 26); # was join($", @ary)
2918 return $self->deparse($op, 26);
2925 my $kid = $op->first;
2926 $kid = $kid->first if $kid->name eq "regcmaybe";
2927 $kid = $kid->first if $kid->name eq "regcreset";
2928 return $self->re_dq($kid);
2931 # osmic acid -- see osmium tetroxide
2934 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2935 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2936 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2940 my($op, $cx, $name, $delim) = @_;
2941 my $kid = $op->first;
2942 my ($binop, $var, $re) = ("", "", "");
2943 if ($op->flags & OPf_STACKED) {
2945 $var = $self->deparse($kid, 20);
2946 $kid = $kid->sibling;
2949 $re = re_uninterp(escape_str(re_unback($op->precomp)));
2951 $re = $self->deparse($kid, 1);
2954 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2955 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2956 $flags .= "i" if $op->pmflags & PMf_FOLD;
2957 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2958 $flags .= "o" if $op->pmflags & PMf_KEEP;
2959 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2960 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2961 $flags = $matchwords{$flags} if $matchwords{$flags};
2962 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2966 $re = single_delim($name, $delim, $re);
2970 return $self->maybe_parens("$var =~ $re", $cx, 20);
2976 sub pp_match { matchop(@_, "m", "/") }
2977 sub pp_pushre { matchop(@_, "m", "/") }
2978 sub pp_qr { matchop(@_, "qr", "") }
2983 my($kid, @exprs, $ary, $expr);
2985 if ($ {$kid->pmreplroot}) {
2986 $ary = '@' . $self->gv_name($kid->pmreplroot);
2988 for (; !null($kid); $kid = $kid->sibling) {
2989 push @exprs, $self->deparse($kid, 6);
2991 $expr = "split(" . join(", ", @exprs) . ")";
2993 return $self->maybe_parens("$ary = $expr", $cx, 7);
2999 # oxime -- any of various compounds obtained chiefly by the action of
3000 # hydroxylamine on aldehydes and ketones and characterized by the
3001 # bivalent grouping C=NOH [Webster's Tenth]
3004 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3005 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3006 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3007 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3012 my $kid = $op->first;
3013 my($binop, $var, $re, $repl) = ("", "", "", "");
3014 if ($op->flags & OPf_STACKED) {
3016 $var = $self->deparse($kid, 20);
3017 $kid = $kid->sibling;
3020 if (null($op->pmreplroot)) {
3021 $repl = $self->dq($kid);
3022 $kid = $kid->sibling;
3024 $repl = $op->pmreplroot->first; # skip substcont
3025 while ($repl->name eq "entereval") {
3026 $repl = $repl->first;
3029 if ($op->pmflags & PMf_EVAL) {
3030 $repl = $self->deparse($repl, 0);
3032 $repl = $self->dq($repl);
3036 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3038 $re = $self->deparse($kid, 1);
3040 $flags .= "e" if $op->pmflags & PMf_EVAL;
3041 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3042 $flags .= "i" if $op->pmflags & PMf_FOLD;
3043 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3044 $flags .= "o" if $op->pmflags & PMf_KEEP;
3045 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3046 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3047 $flags = $substwords{$flags} if $substwords{$flags};
3049 return $self->maybe_parens("$var =~ s"
3050 . double_delim($re, $repl) . $flags,
3053 return "s". double_delim($re, $repl) . $flags;
3062 B::Deparse - Perl compiler backend to produce perl code
3066 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3067 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3071 B::Deparse is a backend module for the Perl compiler that generates
3072 perl source code, based on the internal compiled structure that perl
3073 itself creates after parsing a program. The output of B::Deparse won't
3074 be exactly the same as the original source, since perl doesn't keep
3075 track of comments or whitespace, and there isn't a one-to-one
3076 correspondence between perl's syntactical constructions and their
3077 compiled form, but it will often be close. When you use the B<-p>
3078 option, the output also includes parentheses even when they are not
3079 required by precedence, which can make it easy to see if perl is
3080 parsing your expressions the way you intended.
3082 Please note that this module is mainly new and untested code and is
3083 still under development, so it may change in the future.
3087 As with all compiler backend options, these must follow directly after
3088 the '-MO=Deparse', separated by a comma but not any white space.
3094 Add '#line' declarations to the output based on the line and file
3095 locations of the original code.
3099 Print extra parentheses. Without this option, B::Deparse includes
3100 parentheses in its output only when they are needed, based on the
3101 structure of your program. With B<-p>, it uses parentheses (almost)
3102 whenever they would be legal. This can be useful if you are used to
3103 LISP, or if you want to see how perl parses your input. If you say
3105 if ($var & 0x7f == 65) {print "Gimme an A!"}
3106 print ($which ? $a : $b), "\n";
3107 $name = $ENV{USER} or "Bob";
3109 C<B::Deparse,-p> will print
3112 print('Gimme an A!')
3114 (print(($which ? $a : $b)), '???');
3115 (($name = $ENV{'USER'}) or '???')
3117 which probably isn't what you intended (the C<'???'> is a sign that
3118 perl optimized away a constant value).
3122 Expand double-quoted strings into the corresponding combinations of
3123 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3126 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3130 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3131 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3133 Note that the expanded form represents the way perl handles such
3134 constructions internally -- this option actually turns off the reverse
3135 translation that B::Deparse usually does. On the other hand, note that
3136 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3137 of $y into a string before doing the assignment.
3139 =item B<-u>I<PACKAGE>
3141 Normally, B::Deparse deparses the main code of a program, all the subs
3142 called by the main program (and all the subs called by them,
3143 recursively), and any other subs in the main:: package. To include
3144 subs in other packages that aren't called directly, such as AUTOLOAD,
3145 DESTROY, other subs called automatically by perl, and methods (which
3146 aren't resolved to subs until runtime), use the B<-u> option. The
3147 argument to B<-u> is the name of a package, and should follow directly
3148 after the 'u'. Multiple B<-u> options may be given, separated by
3149 commas. Note that unlike some other backends, B::Deparse doesn't
3150 (yet) try to guess automatically when B<-u> is needed -- you must
3153 =item B<-s>I<LETTERS>
3155 Tweak the style of B::Deparse's output. The letters should follow
3156 directly after the 's', with no space or punctuation. The following
3157 options are available:
3163 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3180 The default is not to cuddle.
3184 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3188 Use tabs for each 8 columns of indent. The default is to use only spaces.
3189 For instance, if the style options are B<-si4T>, a line that's indented
3190 3 times will be preceded by one tab and four spaces; if the options were
3191 B<-si8T>, the same line would be preceded by three tabs.
3193 =item B<v>I<STRING>B<.>
3195 Print I<STRING> for the value of a constant that can't be determined
3196 because it was optimized away (mnemonic: this happens when a constant
3197 is used in B<v>oid context). The end of the string is marked by a period.
3198 The string should be a valid perl expression, generally a constant.
3199 Note that unless it's a number, it probably needs to be quoted, and on
3200 a command line quotes need to be protected from the shell. Some
3201 conventional values include 0, 1, 42, '', 'foo', and
3202 'Useless use of constant omitted' (which may need to be
3203 B<-sv"'Useless use of constant omitted'.">
3204 or something similar depending on your shell). The default is '???'.
3205 If you're using B::Deparse on a module or other file that's require'd,
3206 you shouldn't use a value that evaluates to false, since the customary
3207 true constant at the end of a module will be in void context when the
3208 file is compiled as a main program.
3214 Expand conventional syntax constructions into equivalent ones that expose
3215 their internal operation. I<LEVEL> should be a digit, with higher values
3216 meaning more expansion. As with B<-q>, this actually involves turning off
3217 special cases in B::Deparse's normal operations.
3219 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3220 while loops with continue blocks; for instance
3222 for ($i = 0; $i < 10; ++$i) {
3235 Note that in a few cases this translation can't be perfectly carried back
3236 into the source code -- if the loop's initializer declares a my variable,
3237 for instance, it won't have the correct scope outside of the loop.
3239 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3240 expressions using C<&&>, C<?:> and C<do {}>; for instance
3242 print 'hi' if $nice;
3254 $nice and print 'hi';
3255 $nice and do { print 'hi' };
3256 $nice ? do { print 'hi' } : do { print 'bye' };
3258 Long sequences of elsifs will turn into nested ternary operators, which
3259 B::Deparse doesn't know how to indent nicely.
3263 =head1 USING B::Deparse AS A MODULE
3268 $deparse = B::Deparse->new("-p", "-sC");
3269 $body = $deparse->coderef2text(\&func);
3270 eval "sub func $body"; # the inverse operation
3274 B::Deparse can also be used on a sub-by-sub basis from other perl
3279 $deparse = B::Deparse->new(OPTIONS)
3281 Create an object to store the state of a deparsing operation and any
3282 options. The options are the same as those that can be given on the
3283 command line (see L</OPTIONS>); options that are separated by commas
3284 after B<-MO=Deparse> should be given as separate strings. Some
3285 options, like B<-u>, don't make sense for a single subroutine, so
3288 =head2 ambient_pragmas
3290 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3292 The compilation of a subroutine can be affected by a few compiler
3293 directives, B<pragmas>. These are:
3307 Assigning to the special variable $[
3315 Ordinarily, if you use B::Deparse on a subroutine which has
3316 been compiled in the presence of one or more of these pragmas,
3317 the output will include statements to turn on the appropriate
3318 directives. So if you then compile the code returned by coderef2text,
3319 it will behave the same way as the subroutine which you deparsed.
3321 However, you may know that you intend to use the results in a
3322 particular context, where some pragmas are already in scope. In
3323 this case, you use the B<ambient_pragmas> method to describe the
3324 assumptions you wish to make.
3326 The parameters it accepts are:
3332 Takes a string, possibly containing several values separated
3333 by whitespace. The special values "all" and "none" mean what you'd
3336 $deparse->ambient_pragmas(strict => 'subs refs');
3340 Takes a number, the value of the array base $[.
3344 If the value is true, then the B<integer> pragma is assumed to
3345 be in the ambient scope, otherwise not.
3349 Takes a string, possibly containing a whitespace-separated list of
3350 values. The values "all" and "none" are special, again. It's also
3351 permissible to pass an array reference here.
3353 $deparser->ambient_pragmas(warnings => [qw[void io]]);
3355 If one of the values is the string "FATAL", then all the warnings
3356 in that list will be considered fatal, just as with the B<warnings>
3357 pragma itself. Should you need to specify that some warnings are
3358 fatal, and others are merely enabled, you can pass the B<warnings>
3361 $deparser->ambient_pragmas(
3363 warnings => [FATAL => qw/void io/],
3366 See L<perllexwarn> for more information about lexical warnings.
3372 These two parameters are used to specify the ambient pragmas in
3373 the format used by the special variables $^H and ${^WARNING_BITS}.
3375 They exist principally so that you can write code like:
3377 { my ($hint_bits, $warning_bits);
3378 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
3379 $deparser->ambient_pragmas (
3380 hint_bits => $hint_bits,
3381 warning_bits => $warning_bits,
3385 which specifies that the ambient pragmas are exactly those which
3386 are in scope at the point of calling.
3392 $body = $deparse->coderef2text(\&func)
3393 $body = $deparse->coderef2text(sub ($$) { ... })
3395 Return source code for the body of a subroutine (a block, optionally
3396 preceded by a prototype in parens), given a reference to the
3397 sub. Because a subroutine can have no names, or more than one name,
3398 this method doesn't return a complete subroutine definition -- if you
3399 want to eval the result, you should prepend "sub subname ", or "sub "
3400 for an anonymous function constructor. Unless the sub was defined in
3401 the main:: package, the code will include a package declaration.
3405 See the 'to do' list at the beginning of the module file.
3409 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
3410 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3411 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3412 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.