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 # - {} around variables in strings ("${var}letters")
100 # - left/right context
101 # - recognize `use utf8', `use integer', etc
102 # - treat top-level block specially for incremental output
103 # - interpret high bit chars in string as utf8 \x{...} (when?)
104 # - copy comments (look at real text with $^P?)
105 # - avoid semis in one-statement blocks
106 # - associativity of &&=, ||=, ?:
107 # - ',' => '=>' (auto-unquote?)
108 # - break long lines ("\r" as discretionary break?)
109 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
110 # - more style options: brace style, hex vs. octal, quotes, ...
111 # - print big ints as hex/octal instead of decimal (heuristic?)
112 # - handle `my $x if 0'?
113 # - include values of variables (e.g. set in BEGIN)
114 # - coordinate with Data::Dumper (both directions? see previous)
115 # - version using op_next instead of op_first/sibling?
116 # - avoid string copies (pass arrays, one big join?)
118 # - -uPackage:: descend recursively?
122 # Tests that will always fail:
123 # comp/redef.t -- all (redefinition happens at compile time)
125 # Object fields (were globals):
128 # (local($a), local($b)) and local($a, $b) have the same internal
129 # representation but the short form looks better. We notice we can
130 # use a large-scale local when checking the list, but need to prevent
131 # individual locals too. This hash holds the addresses of OPs that
132 # have already had their local-ness accounted for. The same thing
136 # CV for current sub (or main program) being deparsed
139 # name of the current package for deparsed code
142 # array of [cop_seq, GV, is_format?] for subs and formats we still
146 # as above, but [name, prototype] for subs that never got a GV
148 # subs_done, forms_done:
149 # keys are addresses of GVs for subs and formats we've already
150 # deparsed (or at least put into subs_todo)
155 # cuddle: ` ' or `\n', depending on -sC
160 # A little explanation of how precedence contexts and associativity
163 # deparse() calls each per-op subroutine with an argument $cx (short
164 # for context, but not the same as the cx* in the perl core), which is
165 # a number describing the op's parents in terms of precedence, whether
166 # they're inside an expression or at statement level, etc. (see
167 # chart below). When ops with children call deparse on them, they pass
168 # along their precedence. Fractional values are used to implement
169 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
170 # parentheses hacks. The major disadvantage of this scheme is that
171 # it doesn't know about right sides and left sides, so say if you
172 # assign a listop to a variable, it can't tell it's allowed to leave
173 # the parens off the listop.
176 # 26 [TODO] inside interpolation context ("")
177 # 25 left terms and list operators (leftward)
181 # 21 right ! ~ \ and unary + and -
186 # 16 nonassoc named unary operators
187 # 15 nonassoc < > <= >= lt gt le ge
188 # 14 nonassoc == != <=> eq ne cmp
195 # 7 right = += -= *= etc.
197 # 5 nonassoc list operators (rightward)
201 # 1 statement modifiers
204 # Nonprinting characters with special meaning:
205 # \cS - steal parens (see maybe_parens_unop)
206 # \n - newline and indent
207 # \t - increase indent
208 # \b - decrease indent (`outdent')
209 # \f - flush left (no indent)
210 # \cK - kill following semicolon, if any
214 return class($op) eq "NULL";
219 my($gv, $cv, $is_form) = @_;
221 if (!null($cv->START) and is_state($cv->START)) {
222 $seq = $cv->START->cop_seq;
226 push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
231 my $ent = shift @{$self->{'subs_todo'}};
232 my $name = $self->gv_name($ent->[1]);
234 return "format $name =\n"
235 . $self->deparse_format($ent->[1]->FORM). "\n";
237 return "sub $name " . $self->deparse_sub($ent->[1]->CV);
244 if ($op->flags & OPf_KIDS) {
246 for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
247 walk_tree($kid, $sub);
256 $op = shift if null $op;
257 return if !$op or null $op;
260 if ($op->name eq "gv") {
261 my $gv = $self->gv_or_padgv($op);
262 if ($op->next->name eq "entersub") {
263 return if $self->{'subs_done'}{$$gv}++;
264 return if class($gv->CV) eq "SPECIAL";
265 $self->todo($gv, $gv->CV, 0);
266 $self->walk_sub($gv->CV);
267 } elsif ($op->next->name eq "enterwrite"
268 or ($op->next->name eq "rv2gv"
269 and $op->next->next->name eq "enterwrite")) {
270 return if $self->{'forms_done'}{$$gv}++;
271 return if class($gv->FORM) eq "SPECIAL";
272 $self->todo($gv, $gv->FORM, 1);
273 $self->walk_sub($gv->FORM);
283 { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
284 if ($pack eq "main") {
287 $pack = $pack . "::";
290 while (($key, $val) = each %stash) {
291 my $class = class($val);
292 if ($class eq "PV") {
294 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
295 } elsif ($class eq "IV") {
297 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
298 } elsif ($class eq "GV") {
299 if (class($val->CV) ne "SPECIAL") {
300 next if $self->{'subs_done'}{$$val}++;
301 $self->todo($val, $val->CV, 0);
302 $self->walk_sub($val->CV);
304 if (class($val->FORM) ne "SPECIAL") {
305 next if $self->{'forms_done'}{$$val}++;
306 $self->todo($val, $val->FORM, 1);
307 $self->walk_sub($val->FORM);
317 foreach $ar (@{$self->{'protos_todo'}}) {
318 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
319 push @ret, "sub " . $ar->[0] . "$proto;\n";
321 delete $self->{'protos_todo'};
329 while (length($opt = substr($opts, 0, 1))) {
331 $self->{'cuddle'} = " ";
332 $opts = substr($opts, 1);
333 } elsif ($opt eq "i") {
334 $opts =~ s/^i(\d+)//;
335 $self->{'indent_size'} = $1;
336 } elsif ($opt eq "T") {
337 $self->{'use_tabs'} = 1;
338 $opts = substr($opts, 1);
339 } elsif ($opt eq "v") {
340 $opts =~ s/^v([^.]*)(.|$)//;
341 $self->{'ex_const'} = $1;
348 my $self = bless {}, $class;
349 $self->{'subs_todo'} = [];
350 $self->{'curstash'} = "main";
351 $self->{'cuddle'} = "\n";
352 $self->{'indent_size'} = 4;
353 $self->{'use_tabs'} = 0;
354 $self->{'expand'} = 0;
355 $self->{'unquote'} = 0;
356 $self->{'linenums'} = 0;
357 $self->{'parens'} = 0;
358 $self->{'ex_const'} = "'???'";
359 $self->{'arybase'} = 0;
360 $self->{'warnings'} = "\0"x12;
361 while (my $arg = shift @_) {
362 if (substr($arg, 0, 2) eq "-u") {
363 $self->stash_subs(substr($arg, 2));
364 } elsif ($arg eq "-p") {
365 $self->{'parens'} = 1;
366 } elsif ($arg eq "-l") {
367 $self->{'linenums'} = 1;
368 } elsif ($arg eq "-q") {
369 $self->{'unquote'} = 1;
370 } elsif (substr($arg, 0, 2) eq "-s") {
371 $self->style_opts(substr $arg, 2);
372 } elsif ($arg =~ /^-x(\d)$/) {
373 $self->{'expand'} = $1;
382 my $self = B::Deparse->new(@args);
383 $self->stash_subs("main");
384 $self->{'curcv'} = main_cv;
385 $self->walk_sub(main_cv, main_start);
386 print $self->print_protos;
387 @{$self->{'subs_todo'}} =
388 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
389 print $self->indent($self->deparse(main_root, 0)), "\n"
390 unless null main_root;
392 while (scalar(@{$self->{'subs_todo'}})) {
393 push @text, $self->next_todo;
395 print $self->indent(join("", @text)), "\n" if @text;
402 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
403 return $self->indent($self->deparse_sub(svref_2object($sub)));
409 # cluck if class($op) eq "NULL";
411 # return $self->$ {\("pp_" . $op->name)}($op, $cx);
413 Carp::confess() unless defined $op;
414 my $meth = "pp_" . $op->name;
415 return $self->$meth($op, $cx);
421 my @lines = split(/\n/, $txt);
426 my $cmd = substr($line, 0, 1);
427 if ($cmd eq "\t" or $cmd eq "\b") {
428 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
429 if ($self->{'use_tabs'}) {
430 $leader = "\t" x ($level / 8) . " " x ($level % 8);
432 $leader = " " x $level;
434 $line = substr($line, 1);
436 if (substr($line, 0, 1) eq "\f") {
437 $line = substr($line, 1); # no indent
439 $line = $leader . $line;
443 return join("\n", @lines);
450 if ($cv->FLAGS & SVf_POK) {
451 $proto = "(". $cv->PV . ") ";
453 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
455 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
456 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
457 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
460 local($self->{'curcv'}) = $cv;
461 local($self->{'curstash'}) = $self->{'curstash'};
462 if (not null $cv->ROOT) {
464 return $proto . "{\n\t" .
465 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
467 my $sv = $cv->const_sv;
469 # uh-oh. inlinable sub... format it differently
470 return $proto . "{ " . const($sv) . " }\n";
472 return $proto . "{}\n";
480 local($self->{'curcv'}) = $form;
481 local($self->{'curstash'}) = $self->{'curstash'};
482 my $op = $form->ROOT;
484 $op = $op->first->first; # skip leavewrite, lineseq
485 while (not null $op) {
486 $op = $op->sibling; # skip nextstate
488 $kid = $op->first->sibling; # skip pushmark
489 push @text, $self->const_sv($kid)->PV;
490 $kid = $kid->sibling;
491 for (; not null $kid; $kid = $kid->sibling) {
492 push @exprs, $self->deparse($kid, 0);
494 push @text, join(", ", @exprs)."\n" if @exprs;
497 return join("", @text) . ".";
502 return $op->name eq "leave" || $op->name eq "scope"
503 || $op->name eq "lineseq"
504 || ($op->name eq "null" && class($op) eq "UNOP"
505 && (is_scope($op->first) || $op->first->name eq "enter"));
509 my $name = $_[0]->name;
510 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
513 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
515 return (!null($op) and null($op->sibling)
516 and $op->name eq "null" and class($op) eq "UNOP"
517 and (($op->first->name =~ /^(and|or)$/
518 and $op->first->first->sibling->name eq "lineseq")
519 or ($op->first->name eq "lineseq"
520 and not null $op->first->first->sibling
521 and $op->first->first->sibling->name eq "unstack")
527 return ($op->name eq "rv2sv" or
528 $op->name eq "padsv" or
529 $op->name eq "gv" or # only in array/hash constructs
530 $op->flags & OPf_KIDS && !null($op->first)
531 && $op->first->name eq "gvsv");
536 my($text, $cx, $prec) = @_;
537 if ($prec < $cx # unary ops nest just fine
538 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
539 or $self->{'parens'})
542 # In a unop, let parent reuse our parens; see maybe_parens_unop
543 $text = "\cS" . $text if $cx == 16;
550 # same as above, but get around the `if it looks like a function' rule
551 sub maybe_parens_unop {
553 my($name, $kid, $cx) = @_;
554 if ($cx > 16 or $self->{'parens'}) {
555 return "$name(" . $self->deparse($kid, 1) . ")";
557 $kid = $self->deparse($kid, 16);
558 if (substr($kid, 0, 1) eq "\cS") {
560 return $name . substr($kid, 1);
561 } elsif (substr($kid, 0, 1) eq "(") {
562 # avoid looks-like-a-function trap with extra parens
563 # (`+' can lead to ambiguities)
564 return "$name(" . $kid . ")";
571 sub maybe_parens_func {
573 my($func, $text, $cx, $prec) = @_;
574 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
575 return "$func($text)";
577 return "$func $text";
583 my($op, $cx, $text) = @_;
584 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
585 if (want_scalar($op)) {
586 return "local $text";
588 return $self->maybe_parens_func("local", $text, $cx, 16);
597 my($op, $cx, $func, @args) = @_;
598 if ($op->private & OPpTARGET_MY) {
599 my $var = $self->padname($op->targ);
600 my $val = $func->($self, $op, 7, @args);
601 return $self->maybe_parens("$var = $val", $cx, 7);
603 return $func->($self, $op, $cx, @args);
610 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
615 my($op, $cx, $text) = @_;
616 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
617 if (want_scalar($op)) {
620 return $self->maybe_parens_func("my", $text, $cx, 16);
627 # The following OPs don't have functions:
629 # pp_padany -- does not exist after parsing
630 # pp_rcatline -- does not exist
632 sub pp_enter { # see also leave
633 cluck "unexpected OP_ENTER";
637 sub pp_pushmark { # see also list
638 cluck "unexpected OP_PUSHMARK";
642 sub pp_leavesub { # see also deparse_sub
643 cluck "unexpected OP_LEAVESUB";
647 sub pp_leavewrite { # see also deparse_format
648 cluck "unexpected OP_LEAVEWRITE";
652 sub pp_method { # see also entersub
653 cluck "unexpected OP_METHOD";
657 sub pp_regcmaybe { # see also regcomp
658 cluck "unexpected OP_REGCMAYBE";
662 sub pp_regcreset { # see also regcomp
663 cluck "unexpected OP_REGCRESET";
667 sub pp_substcont { # see also subst
668 cluck "unexpected OP_SUBSTCONT";
672 sub pp_grepstart { # see also grepwhile
673 cluck "unexpected OP_GREPSTART";
677 sub pp_mapstart { # see also mapwhile
678 cluck "unexpected OP_MAPSTART";
682 sub pp_flip { # see also flop
683 cluck "unexpected OP_FLIP";
687 sub pp_iter { # see also leaveloop
688 cluck "unexpected OP_ITER";
692 sub pp_enteriter { # see also leaveloop
693 cluck "unexpected OP_ENTERITER";
697 sub pp_enterloop { # see also leaveloop
698 cluck "unexpected OP_ENTERLOOP";
702 sub pp_leaveeval { # see also entereval
703 cluck "unexpected OP_LEAVEEVAL";
707 sub pp_entertry { # see also leavetry
708 cluck "unexpected OP_ENTERTRY";
716 for (my $i = 0; $i < @ops; $i++) {
718 if (is_state $ops[$i]) {
719 $expr = $self->deparse($ops[$i], 0);
723 if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and
724 $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3)
726 push @exprs, $expr . $self->for_loop($ops[$i], 0);
730 $expr .= $self->deparse($ops[$i], 0);
731 push @exprs, $expr if length $expr;
733 for(@exprs[0..@exprs-1]) { s/;\n\z// }
734 return join(";\n", @exprs);
738 my($real_block, $self, $op, $cx) = @_;
741 local($self->{'curstash'}) = $self->{'curstash'} if $real_block;
743 $kid = $op->first->sibling; # skip enter
744 if (is_miniwhile($kid)) {
745 my $top = $kid->first;
746 my $name = $top->name;
747 if ($name eq "and") {
749 } elsif ($name eq "or") {
751 } else { # no conditional -> while 1 or until 0
752 return $self->deparse($top->first, 1) . " while 1";
754 my $cond = $top->first;
755 my $body = $cond->sibling->first; # skip lineseq
756 $cond = $self->deparse($cond, 1);
757 $body = $self->deparse($body, 1);
758 return "$body $name $cond";
763 for (; !null($kid); $kid = $kid->sibling) {
766 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
767 return "do { " . $self->lineseq(@kids) . " }";
769 my $lineseq = $self->lineseq(@kids);
770 return (length ($lineseq) ? "$lineseq;" : "");
774 sub pp_scope { scopeop(0, @_); }
775 sub pp_lineseq { scopeop(0, @_); }
776 sub pp_leave { scopeop(1, @_); }
778 # The BEGIN {} is used here because otherwise this code isn't executed
779 # when you run B::Deparse on itself.
781 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
782 "ENV", "ARGV", "ARGVOUT", "_"); }
787 my $stash = $gv->STASH->NAME;
788 my $name = $gv->SAFENAME;
789 if ($stash eq $self->{'curstash'} or $globalnames{$name}
790 or $name =~ /^[^A-Za-z_]/)
794 $stash = $stash . "::";
796 if ($name =~ /^\^../) {
797 $name = "{$name}"; # ${^WARNING_BITS} etc
799 return $stash . $name;
802 # Notice how subs and formats are inserted between statements here
807 @text = $op->label . ": " if $op->label;
808 my $seq = $op->cop_seq;
809 while (scalar(@{$self->{'subs_todo'}})
810 and $seq > $self->{'subs_todo'}[0][0]) {
811 push @text, $self->next_todo;
813 my $stash = $op->stashpv;
814 if ($stash ne $self->{'curstash'}) {
815 push @text, "package $stash;\n";
816 $self->{'curstash'} = $stash;
818 if ($self->{'linenums'}) {
819 push @text, "\f#line " . $op->line .
820 ' "' . $op->file, qq'"\n';
822 if ($self->{'arybase'} != $op->arybase) {
823 push @text, '$[ = '. $op->arybase .";\n";
824 $self->{'arybase'} = $op->arybase;
827 my $warnings = $op->warnings;
829 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
830 $warning_bits = $warnings::Bits{"all"};
832 elsif ($warnings->isa("B::SPECIAL")) {
833 $warning_bits = "\0"x12;
836 $warning_bits = $warnings->PV;
839 if ($self->{'warnings'} ne $warning_bits) {
840 push @text, 'BEGIN {${^WARNING_BITS} = '. cstring($warning_bits) ."}\n";
841 $self->{'warnings'} = $warning_bits;
844 return join("", @text);
847 sub pp_dbstate { pp_nextstate(@_) }
848 sub pp_setstate { pp_nextstate(@_) }
850 sub pp_unstack { return "" } # see also leaveloop
854 my($op, $cx, $name) = @_;
858 sub pp_stub { baseop(@_, "()") }
859 sub pp_wantarray { baseop(@_, "wantarray") }
860 sub pp_fork { baseop(@_, "fork") }
861 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
862 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
863 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
864 sub pp_tms { baseop(@_, "times") }
865 sub pp_ghostent { baseop(@_, "gethostent") }
866 sub pp_gnetent { baseop(@_, "getnetent") }
867 sub pp_gprotoent { baseop(@_, "getprotoent") }
868 sub pp_gservent { baseop(@_, "getservent") }
869 sub pp_ehostent { baseop(@_, "endhostent") }
870 sub pp_enetent { baseop(@_, "endnetent") }
871 sub pp_eprotoent { baseop(@_, "endprotoent") }
872 sub pp_eservent { baseop(@_, "endservent") }
873 sub pp_gpwent { baseop(@_, "getpwent") }
874 sub pp_spwent { baseop(@_, "setpwent") }
875 sub pp_epwent { baseop(@_, "endpwent") }
876 sub pp_ggrent { baseop(@_, "getgrent") }
877 sub pp_sgrent { baseop(@_, "setgrent") }
878 sub pp_egrent { baseop(@_, "endgrent") }
879 sub pp_getlogin { baseop(@_, "getlogin") }
883 # I couldn't think of a good short name, but this is the category of
884 # symbolic unary operators with interesting precedence
888 my($op, $cx, $name, $prec, $flags) = (@_, 0);
889 my $kid = $op->first;
890 $kid = $self->deparse($kid, $prec);
891 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
895 sub pp_preinc { pfixop(@_, "++", 23) }
896 sub pp_predec { pfixop(@_, "--", 23) }
897 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
898 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
899 sub pp_i_preinc { pfixop(@_, "++", 23) }
900 sub pp_i_predec { pfixop(@_, "--", 23) }
901 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
902 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
903 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
905 sub pp_negate { maybe_targmy(@_, \&real_negate) }
909 if ($op->first->name =~ /^(i_)?negate$/) {
911 $self->pfixop($op, $cx, "-", 21.5);
913 $self->pfixop($op, $cx, "-", 21);
916 sub pp_i_negate { pp_negate(@_) }
922 $self->pfixop($op, $cx, "not ", 4);
924 $self->pfixop($op, $cx, "!", 21);
930 my($op, $cx, $name) = @_;
932 if ($op->flags & OPf_KIDS) {
934 return $self->maybe_parens_unop($name, $kid, $cx);
936 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
940 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
941 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
942 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
943 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
944 sub pp_defined { unop(@_, "defined") }
945 sub pp_undef { unop(@_, "undef") }
946 sub pp_study { unop(@_, "study") }
947 sub pp_ref { unop(@_, "ref") }
948 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
950 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
951 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
952 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
953 sub pp_srand { unop(@_, "srand") }
954 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
955 sub pp_log { maybe_targmy(@_, \&unop, "log") }
956 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
957 sub pp_int { maybe_targmy(@_, \&unop, "int") }
958 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
959 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
960 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
962 sub pp_length { maybe_targmy(@_, \&unop, "length") }
963 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
964 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
966 sub pp_each { unop(@_, "each") }
967 sub pp_values { unop(@_, "values") }
968 sub pp_keys { unop(@_, "keys") }
969 sub pp_pop { unop(@_, "pop") }
970 sub pp_shift { unop(@_, "shift") }
972 sub pp_caller { unop(@_, "caller") }
973 sub pp_reset { unop(@_, "reset") }
974 sub pp_exit { unop(@_, "exit") }
975 sub pp_prototype { unop(@_, "prototype") }
977 sub pp_close { unop(@_, "close") }
978 sub pp_fileno { unop(@_, "fileno") }
979 sub pp_umask { unop(@_, "umask") }
980 sub pp_untie { unop(@_, "untie") }
981 sub pp_tied { unop(@_, "tied") }
982 sub pp_dbmclose { unop(@_, "dbmclose") }
983 sub pp_getc { unop(@_, "getc") }
984 sub pp_eof { unop(@_, "eof") }
985 sub pp_tell { unop(@_, "tell") }
986 sub pp_getsockname { unop(@_, "getsockname") }
987 sub pp_getpeername { unop(@_, "getpeername") }
989 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
990 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
991 sub pp_readlink { unop(@_, "readlink") }
992 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
993 sub pp_readdir { unop(@_, "readdir") }
994 sub pp_telldir { unop(@_, "telldir") }
995 sub pp_rewinddir { unop(@_, "rewinddir") }
996 sub pp_closedir { unop(@_, "closedir") }
997 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
998 sub pp_localtime { unop(@_, "localtime") }
999 sub pp_gmtime { unop(@_, "gmtime") }
1000 sub pp_alarm { unop(@_, "alarm") }
1001 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1003 sub pp_dofile { unop(@_, "do") }
1004 sub pp_entereval { unop(@_, "eval") }
1006 sub pp_ghbyname { unop(@_, "gethostbyname") }
1007 sub pp_gnbyname { unop(@_, "getnetbyname") }
1008 sub pp_gpbyname { unop(@_, "getprotobyname") }
1009 sub pp_shostent { unop(@_, "sethostent") }
1010 sub pp_snetent { unop(@_, "setnetent") }
1011 sub pp_sprotoent { unop(@_, "setprotoent") }
1012 sub pp_sservent { unop(@_, "setservent") }
1013 sub pp_gpwnam { unop(@_, "getpwnam") }
1014 sub pp_gpwuid { unop(@_, "getpwuid") }
1015 sub pp_ggrnam { unop(@_, "getgrnam") }
1016 sub pp_ggrgid { unop(@_, "getgrgid") }
1018 sub pp_lock { unop(@_, "lock") }
1023 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1031 if ($op->private & OPpSLICE) {
1032 return $self->maybe_parens_func("delete",
1033 $self->pp_hslice($op->first, 16),
1036 return $self->maybe_parens_func("delete",
1037 $self->pp_helem($op->first, 16),
1045 if (class($op) eq "UNOP" and $op->first->name eq "const"
1046 and $op->first->private & OPpCONST_BARE)
1048 my $name = $self->const_sv($op->first)->PV;
1051 return "require($name)";
1053 $self->unop($op, $cx, "require");
1060 my $kid = $op->first;
1061 if (not null $kid->sibling) {
1062 # XXX Was a here-doc
1063 return $self->dquote($op);
1065 $self->unop(@_, "scalar");
1072 #cluck "curcv was undef" unless $self->{curcv};
1073 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1079 my $kid = $op->first;
1080 if ($kid->name eq "null") {
1082 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1083 my($pre, $post) = @{{"anonlist" => ["[","]"],
1084 "anonhash" => ["{","}"]}->{$kid->name}};
1086 $kid = $kid->first->sibling; # skip pushmark
1087 for (; !null($kid); $kid = $kid->sibling) {
1088 $expr = $self->deparse($kid, 6);
1091 return $pre . join(", ", @exprs) . $post;
1092 } elsif (!null($kid->sibling) and
1093 $kid->sibling->name eq "anoncode") {
1095 $self->deparse_sub($self->padval($kid->sibling->targ));
1096 } elsif ($kid->name eq "pushmark") {
1097 my $sib_name = $kid->sibling->name;
1098 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1099 and not $kid->sibling->flags & OPf_REF)
1101 # The @a in \(@a) isn't in ref context, but only when the
1103 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1104 } elsif ($sib_name eq 'entersub') {
1105 my $text = $self->deparse($kid->sibling, 1);
1106 # Always show parens for \(&func()), but only with -p otherwise
1107 $text = "($text)" if $self->{'parens'}
1108 or $kid->sibling->private & OPpENTERSUB_AMPER;
1113 $self->pfixop($op, $cx, "\\", 20);
1116 sub pp_srefgen { pp_refgen(@_) }
1121 my $kid = $op->first;
1122 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1123 return "<" . $self->deparse($kid, 1) . ">";
1126 # Unary operators that can occur as pseudo-listops inside double quotes
1129 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1131 if ($op->flags & OPf_KIDS) {
1133 # If there's more than one kid, the first is an ex-pushmark.
1134 $kid = $kid->sibling if not null $kid->sibling;
1135 return $self->maybe_parens_unop($name, $kid, $cx);
1137 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1141 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1142 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1143 sub pp_uc { dq_unop(@_, "uc") }
1144 sub pp_lc { dq_unop(@_, "lc") }
1145 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1149 my ($op, $cx, $name) = @_;
1150 if (class($op) eq "PVOP") {
1151 return "$name " . $op->pv;
1152 } elsif (class($op) eq "OP") {
1154 } elsif (class($op) eq "UNOP") {
1155 # Note -- loop exits are actually exempt from the
1156 # looks-like-a-func rule, but a few extra parens won't hurt
1157 return $self->maybe_parens_unop($name, $op->first, $cx);
1161 sub pp_last { loopex(@_, "last") }
1162 sub pp_next { loopex(@_, "next") }
1163 sub pp_redo { loopex(@_, "redo") }
1164 sub pp_goto { loopex(@_, "goto") }
1165 sub pp_dump { loopex(@_, "dump") }
1169 my($op, $cx, $name) = @_;
1170 if (class($op) eq "UNOP") {
1171 # Genuine `-X' filetests are exempt from the LLAFR, but not
1172 # l?stat(); for the sake of clarity, give'em all parens
1173 return $self->maybe_parens_unop($name, $op->first, $cx);
1174 } elsif (class($op) eq "SVOP") {
1175 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1176 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1181 sub pp_lstat { ftst(@_, "lstat") }
1182 sub pp_stat { ftst(@_, "stat") }
1183 sub pp_ftrread { ftst(@_, "-R") }
1184 sub pp_ftrwrite { ftst(@_, "-W") }
1185 sub pp_ftrexec { ftst(@_, "-X") }
1186 sub pp_fteread { ftst(@_, "-r") }
1187 sub pp_ftewrite { ftst(@_, "-r") }
1188 sub pp_fteexec { ftst(@_, "-r") }
1189 sub pp_ftis { ftst(@_, "-e") }
1190 sub pp_fteowned { ftst(@_, "-O") }
1191 sub pp_ftrowned { ftst(@_, "-o") }
1192 sub pp_ftzero { ftst(@_, "-z") }
1193 sub pp_ftsize { ftst(@_, "-s") }
1194 sub pp_ftmtime { ftst(@_, "-M") }
1195 sub pp_ftatime { ftst(@_, "-A") }
1196 sub pp_ftctime { ftst(@_, "-C") }
1197 sub pp_ftsock { ftst(@_, "-S") }
1198 sub pp_ftchr { ftst(@_, "-c") }
1199 sub pp_ftblk { ftst(@_, "-b") }
1200 sub pp_ftfile { ftst(@_, "-f") }
1201 sub pp_ftdir { ftst(@_, "-d") }
1202 sub pp_ftpipe { ftst(@_, "-p") }
1203 sub pp_ftlink { ftst(@_, "-l") }
1204 sub pp_ftsuid { ftst(@_, "-u") }
1205 sub pp_ftsgid { ftst(@_, "-g") }
1206 sub pp_ftsvtx { ftst(@_, "-k") }
1207 sub pp_fttty { ftst(@_, "-t") }
1208 sub pp_fttext { ftst(@_, "-T") }
1209 sub pp_ftbinary { ftst(@_, "-B") }
1211 sub SWAP_CHILDREN () { 1 }
1212 sub ASSIGN () { 2 } # has OP= variant
1218 my $name = $op->name;
1219 if ($name eq "concat" and $op->first->name eq "concat") {
1220 # avoid spurious `=' -- see comment in pp_concat
1223 if ($name eq "null" and class($op) eq "UNOP"
1224 and $op->first->name =~ /^(and|x?or)$/
1225 and null $op->first->sibling)
1227 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1228 # with a null that's used as the common end point of the two
1229 # flows of control. For precedence purposes, ignore it.
1230 # (COND_EXPRs have these too, but we don't bother with
1231 # their associativity).
1232 return assoc_class($op->first);
1234 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1237 # Left associative operators, like `+', for which
1238 # $a + $b + $c is equivalent to ($a + $b) + $c
1241 %left = ('multiply' => 19, 'i_multiply' => 19,
1242 'divide' => 19, 'i_divide' => 19,
1243 'modulo' => 19, 'i_modulo' => 19,
1245 'add' => 18, 'i_add' => 18,
1246 'subtract' => 18, 'i_subtract' => 18,
1248 'left_shift' => 17, 'right_shift' => 17,
1250 'bit_or' => 12, 'bit_xor' => 12,
1252 'or' => 2, 'xor' => 2,
1256 sub deparse_binop_left {
1258 my($op, $left, $prec) = @_;
1259 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1260 and $left{assoc_class($op)} == $left{assoc_class($left)})
1262 return $self->deparse($left, $prec - .00001);
1264 return $self->deparse($left, $prec);
1268 # Right associative operators, like `=', for which
1269 # $a = $b = $c is equivalent to $a = ($b = $c)
1272 %right = ('pow' => 22,
1273 'sassign=' => 7, 'aassign=' => 7,
1274 'multiply=' => 7, 'i_multiply=' => 7,
1275 'divide=' => 7, 'i_divide=' => 7,
1276 'modulo=' => 7, 'i_modulo=' => 7,
1278 'add=' => 7, 'i_add=' => 7,
1279 'subtract=' => 7, 'i_subtract=' => 7,
1281 'left_shift=' => 7, 'right_shift=' => 7,
1283 'bit_or=' => 7, 'bit_xor=' => 7,
1289 sub deparse_binop_right {
1291 my($op, $right, $prec) = @_;
1292 if ($right{assoc_class($op)} && $right{assoc_class($right)}
1293 and $right{assoc_class($op)} == $right{assoc_class($right)})
1295 return $self->deparse($right, $prec - .00001);
1297 return $self->deparse($right, $prec);
1303 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1304 my $left = $op->first;
1305 my $right = $op->last;
1307 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1311 if ($flags & SWAP_CHILDREN) {
1312 ($left, $right) = ($right, $left);
1314 $left = $self->deparse_binop_left($op, $left, $prec);
1315 $right = $self->deparse_binop_right($op, $right, $prec);
1316 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1319 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1320 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1321 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1322 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1323 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1324 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1325 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1326 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1327 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1328 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1329 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1331 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1332 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1333 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1334 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1335 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1337 sub pp_eq { binop(@_, "==", 14) }
1338 sub pp_ne { binop(@_, "!=", 14) }
1339 sub pp_lt { binop(@_, "<", 15) }
1340 sub pp_gt { binop(@_, ">", 15) }
1341 sub pp_ge { binop(@_, ">=", 15) }
1342 sub pp_le { binop(@_, "<=", 15) }
1343 sub pp_ncmp { binop(@_, "<=>", 14) }
1344 sub pp_i_eq { binop(@_, "==", 14) }
1345 sub pp_i_ne { binop(@_, "!=", 14) }
1346 sub pp_i_lt { binop(@_, "<", 15) }
1347 sub pp_i_gt { binop(@_, ">", 15) }
1348 sub pp_i_ge { binop(@_, ">=", 15) }
1349 sub pp_i_le { binop(@_, "<=", 15) }
1350 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1352 sub pp_seq { binop(@_, "eq", 14) }
1353 sub pp_sne { binop(@_, "ne", 14) }
1354 sub pp_slt { binop(@_, "lt", 15) }
1355 sub pp_sgt { binop(@_, "gt", 15) }
1356 sub pp_sge { binop(@_, "ge", 15) }
1357 sub pp_sle { binop(@_, "le", 15) }
1358 sub pp_scmp { binop(@_, "cmp", 14) }
1360 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1361 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1363 # `.' is special because concats-of-concats are optimized to save copying
1364 # by making all but the first concat stacked. The effect is as if the
1365 # programmer had written `($a . $b) .= $c', except legal.
1366 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1370 my $left = $op->first;
1371 my $right = $op->last;
1374 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1378 $left = $self->deparse_binop_left($op, $left, $prec);
1379 $right = $self->deparse_binop_right($op, $right, $prec);
1380 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1383 # `x' is weird when the left arg is a list
1387 my $left = $op->first;
1388 my $right = $op->last;
1391 if ($op->flags & OPf_STACKED) {
1395 if (null($right)) { # list repeat; count is inside left-side ex-list
1396 my $kid = $left->first->sibling; # skip pushmark
1398 for (; !null($kid->sibling); $kid = $kid->sibling) {
1399 push @exprs, $self->deparse($kid, 6);
1402 $left = "(" . join(", ", @exprs). ")";
1404 $left = $self->deparse_binop_left($op, $left, $prec);
1406 $right = $self->deparse_binop_right($op, $right, $prec);
1407 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1412 my ($op, $cx, $type) = @_;
1413 my $left = $op->first;
1414 my $right = $left->sibling;
1415 $left = $self->deparse($left, 9);
1416 $right = $self->deparse($right, 9);
1417 return $self->maybe_parens("$left $type $right", $cx, 9);
1423 my $flip = $op->first;
1424 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1425 return $self->range($flip->first, $cx, $type);
1428 # one-line while/until is handled in pp_leave
1432 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1433 my $left = $op->first;
1434 my $right = $op->first->sibling;
1435 if ($cx == 0 and is_scope($right) and $blockname
1436 and $self->{'expand'} < 7)
1438 $left = $self->deparse($left, 1);
1439 $right = $self->deparse($right, 0);
1440 return "$blockname ($left) {\n\t$right\n\b}\cK";
1441 } elsif ($cx == 0 and $blockname and not $self->{'parens'}
1442 and $self->{'expand'} < 7) { # $b if $a
1443 $right = $self->deparse($right, 1);
1444 $left = $self->deparse($left, 1);
1445 return "$right $blockname $left";
1446 } elsif ($cx > $lowprec and $highop) { # $a && $b
1447 $left = $self->deparse_binop_left($op, $left, $highprec);
1448 $right = $self->deparse_binop_right($op, $right, $highprec);
1449 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1450 } else { # $a and $b
1451 $left = $self->deparse_binop_left($op, $left, $lowprec);
1452 $right = $self->deparse_binop_right($op, $right, $lowprec);
1453 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1457 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1458 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1460 # xor is syntactically a logop, but it's really a binop (contrary to
1461 # old versions of opcode.pl). Syntax is what matters here.
1462 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1466 my ($op, $cx, $opname) = @_;
1467 my $left = $op->first;
1468 my $right = $op->first->sibling->first; # skip sassign
1469 $left = $self->deparse($left, 7);
1470 $right = $self->deparse($right, 7);
1471 return $self->maybe_parens("$left $opname $right", $cx, 7);
1474 sub pp_andassign { logassignop(@_, "&&=") }
1475 sub pp_orassign { logassignop(@_, "||=") }
1479 my($op, $cx, $name) = @_;
1481 my $parens = ($cx >= 5) || $self->{'parens'};
1482 my $kid = $op->first->sibling;
1483 return $name if null $kid;
1484 my $first = $self->deparse($kid, 6);
1485 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1486 push @exprs, $first;
1487 $kid = $kid->sibling;
1488 for (; !null($kid); $kid = $kid->sibling) {
1489 push @exprs, $self->deparse($kid, 6);
1492 return "$name(" . join(", ", @exprs) . ")";
1494 return "$name " . join(", ", @exprs);
1498 sub pp_bless { listop(@_, "bless") }
1499 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
1500 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1501 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1502 sub pp_index { maybe_targmy(@_, \&listop, "index") }
1503 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
1504 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
1505 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1506 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
1507 sub pp_unpack { listop(@_, "unpack") }
1508 sub pp_pack { listop(@_, "pack") }
1509 sub pp_join { maybe_targmy(@_, \&listop, "join") }
1510 sub pp_splice { listop(@_, "splice") }
1511 sub pp_push { maybe_targmy(@_, \&listop, "push") }
1512 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
1513 sub pp_reverse { listop(@_, "reverse") }
1514 sub pp_warn { listop(@_, "warn") }
1515 sub pp_die { listop(@_, "die") }
1516 # Actually, return is exempt from the LLAFR (see examples in this very
1517 # module!), but for consistency's sake, ignore that fact
1518 sub pp_return { listop(@_, "return") }
1519 sub pp_open { listop(@_, "open") }
1520 sub pp_pipe_op { listop(@_, "pipe") }
1521 sub pp_tie { listop(@_, "tie") }
1522 sub pp_binmode { listop(@_, "binmode") }
1523 sub pp_dbmopen { listop(@_, "dbmopen") }
1524 sub pp_sselect { listop(@_, "select") }
1525 sub pp_select { listop(@_, "select") }
1526 sub pp_read { listop(@_, "read") }
1527 sub pp_sysopen { listop(@_, "sysopen") }
1528 sub pp_sysseek { listop(@_, "sysseek") }
1529 sub pp_sysread { listop(@_, "sysread") }
1530 sub pp_syswrite { listop(@_, "syswrite") }
1531 sub pp_send { listop(@_, "send") }
1532 sub pp_recv { listop(@_, "recv") }
1533 sub pp_seek { listop(@_, "seek") }
1534 sub pp_fcntl { listop(@_, "fcntl") }
1535 sub pp_ioctl { listop(@_, "ioctl") }
1536 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
1537 sub pp_socket { listop(@_, "socket") }
1538 sub pp_sockpair { listop(@_, "sockpair") }
1539 sub pp_bind { listop(@_, "bind") }
1540 sub pp_connect { listop(@_, "connect") }
1541 sub pp_listen { listop(@_, "listen") }
1542 sub pp_accept { listop(@_, "accept") }
1543 sub pp_shutdown { listop(@_, "shutdown") }
1544 sub pp_gsockopt { listop(@_, "getsockopt") }
1545 sub pp_ssockopt { listop(@_, "setsockopt") }
1546 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
1547 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
1548 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
1549 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
1550 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
1551 sub pp_link { maybe_targmy(@_, \&listop, "link") }
1552 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
1553 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
1554 sub pp_open_dir { listop(@_, "opendir") }
1555 sub pp_seekdir { listop(@_, "seekdir") }
1556 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
1557 sub pp_system { maybe_targmy(@_, \&listop, "system") }
1558 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
1559 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
1560 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
1561 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
1562 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
1563 sub pp_shmget { listop(@_, "shmget") }
1564 sub pp_shmctl { listop(@_, "shmctl") }
1565 sub pp_shmread { listop(@_, "shmread") }
1566 sub pp_shmwrite { listop(@_, "shmwrite") }
1567 sub pp_msgget { listop(@_, "msgget") }
1568 sub pp_msgctl { listop(@_, "msgctl") }
1569 sub pp_msgsnd { listop(@_, "msgsnd") }
1570 sub pp_msgrcv { listop(@_, "msgrcv") }
1571 sub pp_semget { listop(@_, "semget") }
1572 sub pp_semctl { listop(@_, "semctl") }
1573 sub pp_semop { listop(@_, "semop") }
1574 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1575 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1576 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1577 sub pp_gsbyname { listop(@_, "getservbyname") }
1578 sub pp_gsbyport { listop(@_, "getservbyport") }
1579 sub pp_syscall { listop(@_, "syscall") }
1584 my $text = $self->dq($op->first->sibling); # skip pushmark
1585 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1586 or $text =~ /[<>]/) {
1587 return 'glob(' . single_delim('qq', '"', $text) . ')';
1589 return '<' . $text . '>';
1593 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1594 # be a filehandle. This could probably be better fixed in the core
1595 # by moving the GV lookup into ck_truc.
1601 my $parens = ($cx >= 5) || $self->{'parens'};
1602 my $kid = $op->first->sibling;
1604 if ($op->flags & OPf_SPECIAL) {
1605 # $kid is an OP_CONST
1606 $fh = $self->const_sv($kid)->PV;
1608 $fh = $self->deparse($kid, 6);
1609 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1611 my $len = $self->deparse($kid->sibling, 6);
1613 return "truncate($fh, $len)";
1615 return "truncate $fh, $len";
1621 my($op, $cx, $name) = @_;
1623 my $kid = $op->first->sibling;
1625 if ($op->flags & OPf_STACKED) {
1627 $indir = $indir->first; # skip rv2gv
1628 if (is_scope($indir)) {
1629 $indir = "{" . $self->deparse($indir, 0) . "}";
1631 $indir = $self->deparse($indir, 24);
1633 $indir = $indir . " ";
1634 $kid = $kid->sibling;
1636 for (; !null($kid); $kid = $kid->sibling) {
1637 $expr = $self->deparse($kid, 6);
1640 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
1644 sub pp_prtf { indirop(@_, "printf") }
1645 sub pp_print { indirop(@_, "print") }
1646 sub pp_sort { indirop(@_, "sort") }
1650 my($op, $cx, $name) = @_;
1652 my $kid = $op->first; # this is the (map|grep)start
1653 $kid = $kid->first->sibling; # skip a pushmark
1654 my $code = $kid->first; # skip a null
1655 if (is_scope $code) {
1656 $code = "{" . $self->deparse($code, 0) . "} ";
1658 $code = $self->deparse($code, 24) . ", ";
1660 $kid = $kid->sibling;
1661 for (; !null($kid); $kid = $kid->sibling) {
1662 $expr = $self->deparse($kid, 6);
1663 push @exprs, $expr if $expr;
1665 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1668 sub pp_mapwhile { mapop(@_, "map") }
1669 sub pp_grepwhile { mapop(@_, "grep") }
1675 my $kid = $op->first->sibling; # skip pushmark
1677 my $local = "either"; # could be local(...) or my(...)
1678 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1679 # This assumes that no other private flags equal 128, and that
1680 # OPs that store things other than flags in their op_private,
1681 # like OP_AELEMFAST, won't be immediate children of a list.
1682 unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
1684 $local = ""; # or not
1687 if ($lop->name =~ /^pad[ash]v$/) { # my()
1688 ($local = "", last) if $local eq "local";
1690 } elsif ($lop->name ne "undef") { # local()
1691 ($local = "", last) if $local eq "my";
1695 $local = "" if $local eq "either"; # no point if it's all undefs
1696 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
1697 for (; !null($kid); $kid = $kid->sibling) {
1699 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
1704 $self->{'avoid_local'}{$$lop}++;
1705 $expr = $self->deparse($kid, 6);
1706 delete $self->{'avoid_local'}{$$lop};
1708 $expr = $self->deparse($kid, 6);
1713 return "$local(" . join(", ", @exprs) . ")";
1715 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1719 sub is_ifelse_cont {
1721 return ($op->name eq "null" and class($op) eq "UNOP"
1722 and $op->first->name =~ /^(and|cond_expr)$/
1723 and is_scope($op->first->first->sibling));
1729 my $cond = $op->first;
1730 my $true = $cond->sibling;
1731 my $false = $true->sibling;
1732 my $cuddle = $self->{'cuddle'};
1733 unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
1734 (is_scope($false) || is_ifelse_cont($false))
1735 and $self->{'expand'} < 7) {
1736 $cond = $self->deparse($cond, 8);
1737 $true = $self->deparse($true, 8);
1738 $false = $self->deparse($false, 8);
1739 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1742 $cond = $self->deparse($cond, 1);
1743 $true = $self->deparse($true, 0);
1744 my $head = "if ($cond) {\n\t$true\n\b}";
1746 while (!null($false) and is_ifelse_cont($false)) {
1747 my $newop = $false->first;
1748 my $newcond = $newop->first;
1749 my $newtrue = $newcond->sibling;
1750 $false = $newtrue->sibling; # last in chain is OP_AND => no else
1751 $newcond = $self->deparse($newcond, 1);
1752 $newtrue = $self->deparse($newtrue, 0);
1753 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1755 if (!null($false)) {
1756 $false = $cuddle . "else {\n\t" .
1757 $self->deparse($false, 0) . "\n\b}\cK";
1761 return $head . join($cuddle, "", @elsifs) . $false;
1766 my($op, $cx, $init) = @_;
1767 my $enter = $op->first;
1768 my $kid = $enter->sibling;
1769 local($self->{'curstash'}) = $self->{'curstash'};
1774 if ($kid->name eq "lineseq") { # bare or infinite loop
1775 if (is_state $kid->last) { # infinite
1776 $head = "for (;;) "; # shorter than while (1)
1782 } elsif ($enter->name eq "enteriter") { # foreach
1783 my $ary = $enter->first->sibling; # first was pushmark
1784 my $var = $ary->sibling;
1785 if ($enter->flags & OPf_STACKED
1786 and not null $ary->first->sibling->sibling)
1788 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1789 $self->deparse($ary->first->sibling->sibling, 9);
1791 $ary = $self->deparse($ary, 1);
1794 if ($enter->flags & OPf_SPECIAL) { # thread special var
1795 $var = $self->pp_threadsv($enter, 1);
1796 } else { # regular my() variable
1797 $var = $self->pp_padsv($enter, 1);
1798 if ($self->padname_sv($enter->targ)->IVX ==
1799 $kid->first->first->sibling->last->cop_seq)
1801 # If the scope of this variable closes at the last
1802 # statement of the loop, it must have been
1804 $var = "my " . $var;
1807 } elsif ($var->name eq "rv2gv") {
1808 $var = $self->pp_rv2sv($var, 1);
1809 } elsif ($var->name eq "gv") {
1810 $var = "\$" . $self->deparse($var, 1);
1812 $head = "foreach $var ($ary) ";
1813 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1814 } elsif ($kid->name eq "null") { # while/until
1816 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
1817 $cond = $self->deparse($kid->first, 1);
1818 $head = "$name ($cond) ";
1819 $body = $kid->first->sibling;
1820 } elsif ($kid->name eq "stub") { # bare and empty
1821 return "{;}"; # {} could be a hashref
1823 # If there isn't a continue block, then the next pointer for the loop
1824 # will point to the unstack, which is kid's penultimate child, except
1825 # in a bare loop, when it will point to the leaveloop. When neither of
1826 # these conditions hold, then the third-to-last child in the continue
1827 # block (or the last in a bare loop).
1828 my $cont_start = $enter->nextop;
1830 if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) {
1832 $cont = $body->last;
1834 $cont = $body->first;
1835 while (!null($cont->sibling->sibling->sibling)) {
1836 $cont = $cont->sibling;
1839 my $state = $body->first;
1840 my $cuddle = $self->{'cuddle'};
1842 for (; $$state != $$cont; $state = $state->sibling) {
1843 push @states, $state;
1845 $body = $self->lineseq(@states);
1846 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
1847 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
1850 $cont = $cuddle . "continue {\n\t" .
1851 $self->deparse($cont, 0) . "\n\b}\cK";
1854 return "" if !defined $body;
1856 $body = $self->deparse($body, 0);
1858 return $head . "{\n\t" . $body . "\n\b}" . $cont;
1861 sub pp_leaveloop { loop_common(@_, "") }
1866 my $init = $self->deparse($op, 1);
1867 return $self->loop_common($op->sibling, $cx, $init);
1872 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
1875 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
1876 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
1881 if (class($op) eq "OP") {
1883 return $self->{'ex_const'} if $op->targ == OP_CONST;
1884 } elsif ($op->first->name eq "pushmark") {
1885 return $self->pp_list($op, $cx);
1886 } elsif ($op->first->name eq "enter") {
1887 return $self->pp_leave($op, $cx);
1888 } elsif ($op->targ == OP_STRINGIFY) {
1889 return $self->dquote($op, $cx);
1890 } elsif (!null($op->first->sibling) and
1891 $op->first->sibling->name eq "readline" and
1892 $op->first->sibling->flags & OPf_STACKED) {
1893 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1894 . $self->deparse($op->first->sibling, 7),
1896 } elsif (!null($op->first->sibling) and
1897 $op->first->sibling->name eq "trans" and
1898 $op->first->sibling->flags & OPf_STACKED) {
1899 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1900 . $self->deparse($op->first->sibling, 20),
1903 return $self->deparse($op->first, $cx);
1910 return $self->padname_sv($targ)->PVX;
1916 return substr($self->padname($op->targ), 1); # skip $/@/%
1922 return $self->maybe_my($op, $cx, $self->padname($op->targ));
1925 sub pp_padav { pp_padsv(@_) }
1926 sub pp_padhv { pp_padsv(@_) }
1931 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1932 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1933 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1940 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
1946 if (class($op) eq "PADOP") {
1947 return $self->padval($op->padix);
1948 } else { # class($op) eq "SVOP"
1956 my $gv = $self->gv_or_padgv($op);
1957 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv));
1963 my $gv = $self->gv_or_padgv($op);
1964 return $self->gv_name($gv);
1970 my $gv = $self->gv_or_padgv($op);
1971 return "\$" . $self->gv_name($gv) . "[" .
1972 ($op->private + $self->{'arybase'}) . "]";
1977 my($op, $cx, $type) = @_;
1978 my $kid = $op->first;
1979 my $str = $self->deparse($kid, 0);
1980 return $type . (is_scalar($kid) ? $str : "{$str}");
1983 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1984 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1985 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1991 if ($op->first->name eq "padav") {
1992 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
1994 return $self->maybe_local($op, $cx,
1995 $self->rv2x($op->first, $cx, '$#'));
1999 # skip down to the old, ex-rv2cv
2000 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
2005 my $kid = $op->first;
2006 if ($kid->name eq "const") { # constant list
2007 my $av = $self->const_sv($kid);
2008 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2010 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2014 sub is_subscriptable {
2016 if ($op->name =~ /^[ahg]elem/) {
2018 } elsif ($op->name eq "entersub") {
2019 my $kid = $op->first;
2020 return 0 unless null $kid->sibling;
2022 $kid = $kid->sibling until null $kid->sibling;
2023 return 0 if is_scope($kid);
2025 return 0 if $kid->name eq "gv";
2026 return 0 if is_scalar($kid);
2027 return is_subscriptable($kid);
2035 my ($op, $cx, $left, $right, $padname) = @_;
2036 my($array, $idx) = ($op->first, $op->first->sibling);
2037 unless ($array->name eq $padname) { # Maybe this has been fixed
2038 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2040 if ($array->name eq $padname) {
2041 $array = $self->padany($array);
2042 } elsif (is_scope($array)) { # ${expr}[0]
2043 $array = "{" . $self->deparse($array, 0) . "}";
2044 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2045 $array = $self->deparse($array, 24);
2047 # $x[20][3]{hi} or expr->[20]
2048 my $arrow = is_subscriptable($array) ? "" : "->";
2049 return $self->deparse($array, 24) . $arrow .
2050 $left . $self->deparse($idx, 1) . $right;
2052 $idx = $self->deparse($idx, 1);
2054 # Outer parens in an array index will confuse perl
2055 # if we're interpolating in a regular expression, i.e.
2056 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2058 # If $self->{parens}, then an initial '(' will
2059 # definitely be paired with a final ')'. If
2060 # !$self->{parens}, the misleading parens won't
2061 # have been added in the first place.
2063 # [You might think that we could get "(...)...(...)"
2064 # where the initial and final parens do not match
2065 # each other. But we can't, because the above would
2066 # only happen if there's an infix binop between the
2067 # two pairs of parens, and *that* means that the whole
2068 # expression would be parenthesized as well.]
2070 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2072 return "\$" . $array . $left . $idx . $right;
2075 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2076 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2081 my($glob, $part) = ($op->first, $op->last);
2082 $glob = $glob->first; # skip rv2gv
2083 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2084 my $scope = is_scope($glob);
2085 $glob = $self->deparse($glob, 0);
2086 $part = $self->deparse($part, 1);
2087 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2092 my ($op, $cx, $left, $right, $regname, $padname) = @_;
2094 my(@elems, $kid, $array, $list);
2095 if (class($op) eq "LISTOP") {
2097 } else { # ex-hslice inside delete()
2098 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2102 $array = $array->first
2103 if $array->name eq $regname or $array->name eq "null";
2104 if (is_scope($array)) {
2105 $array = "{" . $self->deparse($array, 0) . "}";
2106 } elsif ($array->name eq $padname) {
2107 $array = $self->padany($array);
2109 $array = $self->deparse($array, 24);
2111 $kid = $op->first->sibling; # skip pushmark
2112 if ($kid->name eq "list") {
2113 $kid = $kid->first->sibling; # skip list, pushmark
2114 for (; !null $kid; $kid = $kid->sibling) {
2115 push @elems, $self->deparse($kid, 6);
2117 $list = join(", ", @elems);
2119 $list = $self->deparse($kid, 1);
2121 return "\@" . $array . $left . $list . $right;
2124 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2125 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2130 my $idx = $op->first;
2131 my $list = $op->last;
2133 $list = $self->deparse($list, 1);
2134 $idx = $self->deparse($idx, 1);
2135 return "($list)" . "[$idx]";
2140 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2145 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2151 my $kid = $op->first->sibling; # skip pushmark
2152 my($meth, $obj, @exprs);
2153 if ($kid->name eq "list" and want_list $kid) {
2154 # When an indirect object isn't a bareword but the args are in
2155 # parens, the parens aren't part of the method syntax (the LLAFR
2156 # doesn't apply), but they make a list with OPf_PARENS set that
2157 # doesn't get flattened by the append_elem that adds the method,
2158 # making a (object, arg1, arg2, ...) list where the object
2159 # usually is. This can be distinguished from
2160 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2161 # object) because in the later the list is in scalar context
2162 # as the left side of -> always is, while in the former
2163 # the list is in list context as method arguments always are.
2164 # (Good thing there aren't method prototypes!)
2165 $meth = $kid->sibling;
2166 $kid = $kid->first->sibling; # skip pushmark
2168 $kid = $kid->sibling;
2169 for (; not null $kid; $kid = $kid->sibling) {
2170 push @exprs, $self->deparse($kid, 6);
2174 $kid = $kid->sibling;
2175 for (; not null $kid->sibling; $kid = $kid->sibling) {
2176 push @exprs, $self->deparse($kid, 6);
2180 $obj = $self->deparse($obj, 24);
2181 if ($meth->name eq "method_named") {
2182 $meth = $self->const_sv($meth)->PV;
2184 $meth = $meth->first;
2185 if ($meth->name eq "const") {
2186 # As of 5.005_58, this case is probably obsoleted by the
2187 # method_named case above
2188 $meth = $self->const_sv($meth)->PV; # needs to be bare
2190 $meth = $self->deparse($meth, 1);
2193 my $args = join(", ", @exprs);
2194 $kid = $obj . "->" . $meth;
2196 return $kid . "(" . $args . ")"; # parens mandatory
2202 # returns "&" if the prototype doesn't match the args,
2203 # or ("", $args_after_prototype_demunging) if it does.
2206 my($proto, @args) = @_;
2210 # An unbackslashed @ or % gobbles up the rest of the args
2211 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2213 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2216 return "&" if @args;
2217 } elsif ($chr eq ";") {
2219 } elsif ($chr eq "@" or $chr eq "%") {
2220 push @reals, map($self->deparse($_, 6), @args);
2226 if (want_scalar $arg) {
2227 push @reals, $self->deparse($arg, 6);
2231 } elsif ($chr eq "&") {
2232 if ($arg->name =~ /^(s?refgen|undef)$/) {
2233 push @reals, $self->deparse($arg, 6);
2237 } elsif ($chr eq "*") {
2238 if ($arg->name =~ /^s?refgen$/
2239 and $arg->first->first->name eq "rv2gv")
2241 $real = $arg->first->first; # skip refgen, null
2242 if ($real->first->name eq "gv") {
2243 push @reals, $self->deparse($real, 6);
2245 push @reals, $self->deparse($real->first, 6);
2250 } elsif (substr($chr, 0, 1) eq "\\") {
2251 $chr = substr($chr, 1);
2252 if ($arg->name =~ /^s?refgen$/ and
2253 !null($real = $arg->first) and
2254 ($chr eq "\$" && is_scalar($real->first)
2256 && $real->first->sibling->name
2259 && $real->first->sibling->name
2261 #or ($chr eq "&" # This doesn't work
2262 # && $real->first->name eq "rv2cv")
2264 && $real->first->name eq "rv2gv")))
2266 push @reals, $self->deparse($real, 6);
2273 return "&" if $proto and !$doneok; # too few args and no `;'
2274 return "&" if @args; # too many args
2275 return ("", join ", ", @reals);
2281 return $self->method($op, $cx) unless null $op->first->sibling;
2285 if ($op->flags & OPf_SPECIAL) {
2287 } elsif ($op->private & OPpENTERSUB_AMPER) {
2291 $kid = $kid->first->sibling; # skip ex-list, pushmark
2292 for (; not null $kid->sibling; $kid = $kid->sibling) {
2297 if (is_scope($kid)) {
2299 $kid = "{" . $self->deparse($kid, 0) . "}";
2300 } elsif ($kid->first->name eq "gv") {
2301 my $gv = $self->gv_or_padgv($kid->first);
2302 if (class($gv->CV) ne "SPECIAL") {
2303 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2305 $simple = 1; # only calls of named functions can be prototyped
2306 $kid = $self->deparse($kid, 24);
2307 } elsif (is_scalar $kid->first) {
2309 $kid = $self->deparse($kid, 24);
2312 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2313 $kid = $self->deparse($kid, 24) . $arrow;
2316 if (defined $proto and not $amper) {
2317 ($amper, $args) = $self->check_proto($proto, @exprs);
2318 if ($amper eq "&") {
2319 $args = join(", ", map($self->deparse($_, 6), @exprs));
2322 $args = join(", ", map($self->deparse($_, 6), @exprs));
2324 if ($prefix or $amper) {
2325 if ($op->flags & OPf_STACKED) {
2326 return $prefix . $amper . $kid . "(" . $args . ")";
2328 return $prefix . $amper. $kid;
2331 if (defined $proto and $proto eq "") {
2333 } elsif (defined $proto and $proto eq "\$") {
2334 return $self->maybe_parens_func($kid, $args, $cx, 16);
2335 } elsif (defined($proto) && $proto or $simple) {
2336 return $self->maybe_parens_func($kid, $args, $cx, 5);
2338 return "$kid(" . $args . ")";
2343 sub pp_enterwrite { unop(@_, "write") }
2345 # escape things that cause interpolation in double quotes,
2346 # but not character escapes
2349 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2353 # the same, but treat $|, $), and $ at the end of the string differently
2356 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2357 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2361 # character escapes, but not delimiters that might need to be escaped
2362 sub escape_str { # ASCII
2365 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2371 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2372 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2376 # Don't do this for regexen
2379 $str =~ s/\\/\\\\/g;
2383 sub balanced_delim {
2385 my @str = split //, $str;
2386 my($ar, $open, $close, $fail, $c, $cnt);
2387 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2388 ($open, $close) = @$ar;
2389 $fail = 0; $cnt = 0;
2393 } elsif ($c eq $close) {
2402 $fail = 1 if $cnt != 0;
2403 return ($open, "$open$str$close") if not $fail;
2409 my($q, $default, $str) = @_;
2410 return "$default$str$default" if $default and index($str, $default) == -1;
2411 my($succeed, $delim);
2412 ($succeed, $str) = balanced_delim($str);
2413 return "$q$str" if $succeed;
2414 for $delim ('/', '"', '#') {
2415 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2418 $str =~ s/$default/\\$default/g;
2419 return "$default$str$default";
2428 if (class($sv) eq "SPECIAL") {
2429 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2430 } elsif (class($sv) eq "NULL") {
2432 } elsif ($sv->FLAGS & SVf_IOK) {
2433 return $sv->int_value;
2434 } elsif ($sv->FLAGS & SVf_NOK) {
2436 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
2437 return "\\(" . const($sv->RV) . ")"; # constant folded
2440 if ($str =~ /[^ -~]/) { # ASCII for non-printing
2441 return single_delim("qq", '"', uninterp escape_str unback $str);
2443 return single_delim("q", "'", unback $str);
2452 # the constant could be in the pad (under useithreads)
2453 $sv = $self->padval($op->targ) unless $$sv;
2460 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2461 # return $self->const_sv($op)->PV;
2463 my $sv = $self->const_sv($op);
2464 # return const($sv);
2465 if ($op->private & OPpCONST_ARYBASE) {
2469 return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
2475 my $type = $op->name;
2476 if ($type eq "const") {
2477 return uninterp(escape_str(unback($self->const_sv($op)->PV)));
2478 } elsif ($type eq "concat") {
2479 my $first = $self->dq($op->first);
2480 my $last = $self->dq($op->last);
2481 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2482 if ($last =~ /^[{\[\w]/) {
2483 $first =~ s/([%\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2485 return $first . $last;
2486 } elsif ($type eq "uc") {
2487 return '\U' . $self->dq($op->first->sibling) . '\E';
2488 } elsif ($type eq "lc") {
2489 return '\L' . $self->dq($op->first->sibling) . '\E';
2490 } elsif ($type eq "ucfirst") {
2491 return '\u' . $self->dq($op->first->sibling);
2492 } elsif ($type eq "lcfirst") {
2493 return '\l' . $self->dq($op->first->sibling);
2494 } elsif ($type eq "quotemeta") {
2495 return '\Q' . $self->dq($op->first->sibling) . '\E';
2496 } elsif ($type eq "join") {
2497 return $self->deparse($op->last, 26); # was join($", @ary)
2499 return $self->deparse($op, 26);
2507 return single_delim("qx", '`', $self->dq($op->first->sibling));
2513 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2514 return $self->deparse($kid, $cx) if $self->{'unquote'};
2515 $self->maybe_targmy($kid, $cx,
2516 sub {single_delim("qq", '"', $self->dq($_[1]))});
2519 # OP_STRINGIFY is a listop, but it only ever has one arg
2520 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2522 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2523 # note that tr(from)/to/ is OK, but not tr/from/(to)
2525 my($from, $to) = @_;
2526 my($succeed, $delim);
2527 if ($from !~ m[/] and $to !~ m[/]) {
2528 return "/$from/$to/";
2529 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2530 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2533 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2534 return "$from$delim$to$delim" if index($to, $delim) == -1;
2537 return "$from/$to/";
2540 for $delim ('/', '"', '#') { # note no '
2541 return "$delim$from$delim$to$delim"
2542 if index($to . $from, $delim) == -1;
2544 $from =~ s[/][\\/]g;
2546 return "/$from/$to/";
2552 if ($n == ord '\\') {
2554 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2556 } elsif ($n == ord "\a") {
2558 } elsif ($n == ord "\b") {
2560 } elsif ($n == ord "\t") {
2562 } elsif ($n == ord "\n") {
2564 } elsif ($n == ord "\e") {
2566 } elsif ($n == ord "\f") {
2568 } elsif ($n == ord "\r") {
2570 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2571 return '\\c' . chr(ord("@") + $n);
2573 # return '\x' . sprintf("%02x", $n);
2574 return '\\' . sprintf("%03o", $n);
2580 my($str, $c, $tr) = ("");
2581 for ($c = 0; $c < @chars; $c++) {
2584 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2585 $chars[$c + 2] == $tr + 2)
2587 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
2590 $str .= pchr($chars[$c]);
2596 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
2599 sub tr_decode_byte {
2600 my($table, $flags) = @_;
2601 my(@table) = unpack("s256", $table);
2602 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2603 if ($table[ord "-"] != -1 and
2604 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2606 $tr = $table[ord "-"];
2607 $table[ord "-"] = -1;
2611 } else { # -2 ==> delete
2615 for ($c = 0; $c < 256; $c++) {
2618 push @from, $c; push @to, $tr;
2619 } elsif ($tr == -2) {
2623 @from = (@from, @delfrom);
2624 if ($flags & OPpTRANS_COMPLEMENT) {
2627 @from{@from} = (1) x @from;
2628 for ($c = 0; $c < 256; $c++) {
2629 push @newfrom, $c unless $from{$c};
2633 unless ($flags & OPpTRANS_DELETE || !@to) {
2634 pop @to while $#to and $to[$#to] == $to[$#to -1];
2637 $from = collapse(@from);
2638 $to = collapse(@to);
2639 $from .= "-" if $delhyphen;
2640 return ($from, $to);
2645 if ($x == ord "-") {
2652 # XXX This doesn't yet handle all cases correctly either
2654 sub tr_decode_utf8 {
2655 my($swash_hv, $flags) = @_;
2656 my %swash = $swash_hv->ARRAY;
2658 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
2659 my $none = $swash{"NONE"}->IV;
2660 my $extra = $none + 1;
2661 my(@from, @delfrom, @to);
2663 foreach $line (split /\n/, $swash{'LIST'}->PV) {
2664 my($min, $max, $result) = split(/\t/, $line);
2671 $result = hex $result;
2672 if ($result == $extra) {
2673 push @delfrom, [$min, $max];
2675 push @from, [$min, $max];
2676 push @to, [$result, $result + $max - $min];
2679 for my $i (0 .. $#from) {
2680 if ($from[$i][0] == ord '-') {
2681 unshift @from, splice(@from, $i, 1);
2682 unshift @to, splice(@to, $i, 1);
2684 } elsif ($from[$i][1] == ord '-') {
2687 unshift @from, ord '-';
2688 unshift @to, ord '-';
2692 for my $i (0 .. $#delfrom) {
2693 if ($delfrom[$i][0] == ord '-') {
2694 push @delfrom, splice(@delfrom, $i, 1);
2696 } elsif ($delfrom[$i][1] == ord '-') {
2698 push @delfrom, ord '-';
2702 if (defined $final and $to[$#to][1] != $final) {
2703 push @to, [$final, $final];
2705 push @from, @delfrom;
2706 if ($flags & OPpTRANS_COMPLEMENT) {
2709 for my $i (0 .. $#from) {
2710 push @newfrom, [$next, $from[$i][0] - 1];
2711 $next = $from[$i][1] + 1;
2714 for my $range (@newfrom) {
2715 if ($range->[0] <= $range->[1]) {
2720 my($from, $to, $diff);
2721 for my $chunk (@from) {
2722 $diff = $chunk->[1] - $chunk->[0];
2724 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2725 } elsif ($diff == 1) {
2726 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2728 $from .= tr_chr($chunk->[0]);
2731 for my $chunk (@to) {
2732 $diff = $chunk->[1] - $chunk->[0];
2734 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2735 } elsif ($diff == 1) {
2736 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2738 $to .= tr_chr($chunk->[0]);
2741 #$final = sprintf("%04x", $final) if defined $final;
2742 #$none = sprintf("%04x", $none) if defined $none;
2743 #$extra = sprintf("%04x", $extra) if defined $extra;
2744 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
2745 #print STDERR $swash{'LIST'}->PV;
2746 return (escape_str($from), escape_str($to));
2753 if (class($op) eq "PVOP") {
2754 ($from, $to) = tr_decode_byte($op->pv, $op->private);
2755 } else { # class($op) eq "SVOP"
2756 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
2759 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
2760 $flags .= "d" if $op->private & OPpTRANS_DELETE;
2761 $to = "" if $from eq $to and $flags eq "";
2762 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2763 return "tr" . double_delim($from, $to) . $flags;
2766 # Like dq(), but different
2770 my $type = $op->name;
2771 if ($type eq "const") {
2772 return re_uninterp($self->const_sv($op)->PV);
2773 } elsif ($type eq "concat") {
2774 my $first = $self->re_dq($op->first);
2775 my $last = $self->re_dq($op->last);
2776 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2777 if ($last =~ /^[{\[\w]/) {
2778 $first =~ s/([%\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2780 return $first . $last;
2781 } elsif ($type eq "uc") {
2782 return '\U' . $self->re_dq($op->first->sibling) . '\E';
2783 } elsif ($type eq "lc") {
2784 return '\L' . $self->re_dq($op->first->sibling) . '\E';
2785 } elsif ($type eq "ucfirst") {
2786 return '\u' . $self->re_dq($op->first->sibling);
2787 } elsif ($type eq "lcfirst") {
2788 return '\l' . $self->re_dq($op->first->sibling);
2789 } elsif ($type eq "quotemeta") {
2790 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2791 } elsif ($type eq "join") {
2792 return $self->deparse($op->last, 26); # was join($", @ary)
2794 return $self->deparse($op, 26);
2801 my $kid = $op->first;
2802 $kid = $kid->first if $kid->name eq "regcmaybe";
2803 $kid = $kid->first if $kid->name eq "regcreset";
2804 return $self->re_dq($kid);
2807 # osmic acid -- see osmium tetroxide
2810 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2811 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2812 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2816 my($op, $cx, $name, $delim) = @_;
2817 my $kid = $op->first;
2818 my ($binop, $var, $re) = ("", "", "");
2819 if ($op->flags & OPf_STACKED) {
2821 $var = $self->deparse($kid, 20);
2822 $kid = $kid->sibling;
2825 $re = re_uninterp(escape_str($op->precomp));
2827 $re = $self->deparse($kid, 1);
2830 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2831 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2832 $flags .= "i" if $op->pmflags & PMf_FOLD;
2833 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2834 $flags .= "o" if $op->pmflags & PMf_KEEP;
2835 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2836 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2837 $flags = $matchwords{$flags} if $matchwords{$flags};
2838 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2842 $re = single_delim($name, $delim, $re);
2846 return $self->maybe_parens("$var =~ $re", $cx, 20);
2852 sub pp_match { matchop(@_, "m", "/") }
2853 sub pp_pushre { matchop(@_, "m", "/") }
2854 sub pp_qr { matchop(@_, "qr", "") }
2859 my($kid, @exprs, $ary, $expr);
2861 if ($ {$kid->pmreplroot}) {
2862 $ary = '@' . $self->gv_name($kid->pmreplroot);
2864 for (; !null($kid); $kid = $kid->sibling) {
2865 push @exprs, $self->deparse($kid, 6);
2867 $expr = "split(" . join(", ", @exprs) . ")";
2869 return $self->maybe_parens("$ary = $expr", $cx, 7);
2875 # oxime -- any of various compounds obtained chiefly by the action of
2876 # hydroxylamine on aldehydes and ketones and characterized by the
2877 # bivalent grouping C=NOH [Webster's Tenth]
2880 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2881 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2882 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2883 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2888 my $kid = $op->first;
2889 my($binop, $var, $re, $repl) = ("", "", "", "");
2890 if ($op->flags & OPf_STACKED) {
2892 $var = $self->deparse($kid, 20);
2893 $kid = $kid->sibling;
2896 if (null($op->pmreplroot)) {
2897 $repl = $self->dq($kid);
2898 $kid = $kid->sibling;
2900 $repl = $op->pmreplroot->first; # skip substcont
2901 while ($repl->name eq "entereval") {
2902 $repl = $repl->first;
2905 if ($op->pmflags & PMf_EVAL) {
2906 $repl = $self->deparse($repl, 0);
2908 $repl = $self->dq($repl);
2912 $re = re_uninterp(escape_str($op->precomp));
2914 $re = $self->deparse($kid, 1);
2916 $flags .= "e" if $op->pmflags & PMf_EVAL;
2917 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2918 $flags .= "i" if $op->pmflags & PMf_FOLD;
2919 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2920 $flags .= "o" if $op->pmflags & PMf_KEEP;
2921 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2922 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2923 $flags = $substwords{$flags} if $substwords{$flags};
2925 return $self->maybe_parens("$var =~ s"
2926 . double_delim($re, $repl) . $flags,
2929 return "s". double_delim($re, $repl) . $flags;
2938 B::Deparse - Perl compiler backend to produce perl code
2942 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
2943 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
2947 B::Deparse is a backend module for the Perl compiler that generates
2948 perl source code, based on the internal compiled structure that perl
2949 itself creates after parsing a program. The output of B::Deparse won't
2950 be exactly the same as the original source, since perl doesn't keep
2951 track of comments or whitespace, and there isn't a one-to-one
2952 correspondence between perl's syntactical constructions and their
2953 compiled form, but it will often be close. When you use the B<-p>
2954 option, the output also includes parentheses even when they are not
2955 required by precedence, which can make it easy to see if perl is
2956 parsing your expressions the way you intended.
2958 Please note that this module is mainly new and untested code and is
2959 still under development, so it may change in the future.
2963 As with all compiler backend options, these must follow directly after
2964 the '-MO=Deparse', separated by a comma but not any white space.
2970 Add '#line' declarations to the output based on the line and file
2971 locations of the original code.
2975 Print extra parentheses. Without this option, B::Deparse includes
2976 parentheses in its output only when they are needed, based on the
2977 structure of your program. With B<-p>, it uses parentheses (almost)
2978 whenever they would be legal. This can be useful if you are used to
2979 LISP, or if you want to see how perl parses your input. If you say
2981 if ($var & 0x7f == 65) {print "Gimme an A!"}
2982 print ($which ? $a : $b), "\n";
2983 $name = $ENV{USER} or "Bob";
2985 C<B::Deparse,-p> will print
2988 print('Gimme an A!')
2990 (print(($which ? $a : $b)), '???');
2991 (($name = $ENV{'USER'}) or '???')
2993 which probably isn't what you intended (the C<'???'> is a sign that
2994 perl optimized away a constant value).
2998 Expand double-quoted strings into the corresponding combinations of
2999 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3002 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3006 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3007 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3009 Note that the expanded form represents the way perl handles such
3010 constructions internally -- this option actually turns off the reverse
3011 translation that B::Deparse usually does. On the other hand, note that
3012 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3013 of $y into a string before doing the assignment.
3015 =item B<-u>I<PACKAGE>
3017 Normally, B::Deparse deparses the main code of a program, all the subs
3018 called by the main program (and all the subs called by them,
3019 recursively), and any other subs in the main:: package. To include
3020 subs in other packages that aren't called directly, such as AUTOLOAD,
3021 DESTROY, other subs called automatically by perl, and methods (which
3022 aren't resolved to subs until runtime), use the B<-u> option. The
3023 argument to B<-u> is the name of a package, and should follow directly
3024 after the 'u'. Multiple B<-u> options may be given, separated by
3025 commas. Note that unlike some other backends, B::Deparse doesn't
3026 (yet) try to guess automatically when B<-u> is needed -- you must
3029 =item B<-s>I<LETTERS>
3031 Tweak the style of B::Deparse's output. The letters should follow
3032 directly after the 's', with no space or punctuation. The following
3033 options are available:
3039 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3056 The default is not to cuddle.
3060 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3064 Use tabs for each 8 columns of indent. The default is to use only spaces.
3065 For instance, if the style options are B<-si4T>, a line that's indented
3066 3 times will be preceded by one tab and four spaces; if the options were
3067 B<-si8T>, the same line would be preceded by three tabs.
3069 =item B<v>I<STRING>B<.>
3071 Print I<STRING> for the value of a constant that can't be determined
3072 because it was optimized away (mnemonic: this happens when a constant
3073 is used in B<v>oid context). The end of the string is marked by a period.
3074 The string should be a valid perl expression, generally a constant.
3075 Note that unless it's a number, it probably needs to be quoted, and on
3076 a command line quotes need to be protected from the shell. Some
3077 conventional values include 0, 1, 42, '', 'foo', and
3078 'Useless use of constant omitted' (which may need to be
3079 B<-sv"'Useless use of constant omitted'.">
3080 or something similar depending on your shell). The default is '???'.
3081 If you're using B::Deparse on a module or other file that's require'd,
3082 you shouldn't use a value that evaluates to false, since the customary
3083 true constant at the end of a module will be in void context when the
3084 file is compiled as a main program.
3090 Expand conventional syntax constructions into equivalent ones that expose
3091 their internal operation. I<LEVEL> should be a digit, with higher values
3092 meaning more expansion. As with B<-q>, this actually involves turning off
3093 special cases in B::Deparse's normal operations.
3095 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3096 while loops with continue blocks; for instance
3098 for ($i = 0; $i < 10; ++$i) {
3111 Note that in a few cases this translation can't be perfectly carried back
3112 into the source code -- if the loop's initializer declares a my variable,
3113 for instance, it won't have the correct scope outside of the loop.
3115 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3116 expressions using C<&&>, C<?:> and C<do {}>; for instance
3118 print 'hi' if $nice;
3130 $nice and print 'hi';
3131 $nice and do { print 'hi' };
3132 $nice ? do { print 'hi' } : do { print 'bye' };
3134 Long sequences of elsifs will turn into nested ternary operators, which
3135 B::Deparse doesn't know how to indent nicely.
3139 =head1 USING B::Deparse AS A MODULE
3144 $deparse = B::Deparse->new("-p", "-sC");
3145 $body = $deparse->coderef2text(\&func);
3146 eval "sub func $body"; # the inverse operation
3150 B::Deparse can also be used on a sub-by-sub basis from other perl
3155 $deparse = B::Deparse->new(OPTIONS)
3157 Create an object to store the state of a deparsing operation and any
3158 options. The options are the same as those that can be given on the
3159 command line (see L</OPTIONS>); options that are separated by commas
3160 after B<-MO=Deparse> should be given as separate strings. Some
3161 options, like B<-u>, don't make sense for a single subroutine, so
3166 $body = $deparse->coderef2text(\&func)
3167 $body = $deparse->coderef2text(sub ($$) { ... })
3169 Return source code for the body of a subroutine (a block, optionally
3170 preceded by a prototype in parens), given a reference to the
3171 sub. Because a subroutine can have no names, or more than one name,
3172 this method doesn't return a complete subroutine definition -- if you
3173 want to eval the result, you should prepend "sub subname ", or "sub "
3174 for an anonymous function constructor. Unless the sub was defined in
3175 the main:: package, the code will include a package declaration.
3179 See the 'to do' list at the beginning of the module file.
3183 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
3184 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3185 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3186 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.