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
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
16 SVf_IOK SVf_NOK SVf_ROK SVf_POK
17 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
18 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
22 # Changes between 0.50 and 0.51:
23 # - fixed nulled leave with live enter in sort { }
24 # - fixed reference constants (\"str")
25 # - handle empty programs gracefully
26 # - handle infinte loops (for (;;) {}, while (1) {})
27 # - differentiate between `for my $x ...' and `my $x; for $x ...'
28 # - various minor cleanups
29 # - moved globals into an object
30 # - added `-u', like B::C
31 # - package declarations using cop_stash
32 # - subs, formats and code sorted by cop_seq
33 # Changes between 0.51 and 0.52:
34 # - added pp_threadsv (special variables under USE_THREADS)
35 # - added documentation
36 # Changes between 0.52 and 0.53:
37 # - many changes adding precedence contexts and associativity
38 # - added `-p' and `-s' output style options
39 # - various other minor fixes
40 # Changes between 0.53 and 0.54:
41 # - added support for new `for (1..100)' optimization,
43 # Changes between 0.54 and 0.55:
44 # - added support for new qr// construct
45 # - added support for new pp_regcreset OP
46 # Changes between 0.55 and 0.56:
47 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
48 # - fixed $# on non-lexicals broken in last big rewrite
49 # - added temporary fix for change in opcode of OP_STRINGIFY
50 # - fixed problem in 0.54's for() patch in `for (@ary)'
51 # - fixed precedence in conditional of ?:
52 # - tweaked list paren elimination in `my($x) = @_'
53 # - made continue-block detection trickier wrt. null ops
54 # - fixed various prototype problems in pp_entersub
55 # - added support for sub prototypes that never get GVs
56 # - added unquoting for special filehandle first arg in truncate
57 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
58 # - added semicolons at the ends of blocks
59 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
60 # Changes between 0.56 and 0.561:
61 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
62 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
63 # Changes between 0.561 and 0.57:
64 # - stylistic changes to symbolic constant stuff
65 # - handled scope in s///e replacement code
66 # - added unquote option for expanding "" into concats, etc.
67 # - split method and proto parts of pp_entersub into separate functions
68 # - various minor cleanups
70 # - added parens in \&foo (patch by Albert Dvornik)
71 # Changes between 0.57 and 0.58:
72 # - fixed `0' statements that weren't being printed
73 # - added methods for use from other programs
74 # (based on patches from James Duncan and Hugo van der Sanden)
75 # - added -si and -sT to control indenting (also based on a patch from Hugo)
76 # - added -sv to print something else instead of '???'
77 # - preliminary version of utf8 tr/// handling
79 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
80 # - added support for Hugo's new OP_SETSTATE (like nextstate)
81 # Changes between 0.58 and 0.59
82 # - added support for Chip's OP_METHOD_NAMED
83 # - added support for Ilya's OPpTARGET_MY optimization
84 # - elided arrows before `()' subscripts when possible
87 # - finish tr/// changes
88 # - add option for even more parens (generalize \&foo change)
89 # - {} around variables in strings ("${var}letters")
92 # - left/right context
93 # - recognize `use utf8', `use integer', etc
94 # - treat top-level block specially for incremental output
95 # - interpret in high bit chars in string as utf8 \x{...} (when?)
96 # - copy comments (look at real text with $^P?)
97 # - avoid semis in one-statement blocks
98 # - associativity of &&=, ||=, ?:
99 # - ',' => '=>' (auto-unquote?)
100 # - break long lines ("\r" as discretionary break?)
101 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
102 # - more style options: brace style, hex vs. octal, quotes, ...
103 # - print big ints as hex/octal instead of decimal (heuristic?)
104 # - handle `my $x if 0'?
105 # - include values of variables (e.g. set in BEGIN)
106 # - coordinate with Data::Dumper (both directions? see previous)
107 # - version using op_next instead of op_first/sibling?
108 # - avoid string copies (pass arrays, one big join?)
110 # - while{} with one-statement continue => for(; XXX; XXX) {}?
111 # - -uPackage:: descend recursively?
115 # Tests that will always fail:
116 # comp/redef.t -- all (redefinition happens at compile time)
118 # Object fields (were globals):
121 # (local($a), local($b)) and local($a, $b) have the same internal
122 # representation but the short form looks better. We notice we can
123 # use a large-scale local when checking the list, but need to prevent
124 # individual locals too. This hash holds the addresses of OPs that
125 # have already had their local-ness accounted for. The same thing
129 # CV for current sub (or main program) being deparsed
132 # name of the current package for deparsed code
135 # array of [cop_seq, GV, is_format?] for subs and formats we still
139 # as above, but [name, prototype] for subs that never got a GV
141 # subs_done, forms_done:
142 # keys are addresses of GVs for subs and formats we've already
143 # deparsed (or at least put into subs_todo)
148 # cuddle: ` ' or `\n', depending on -sC
153 # A little explanation of how precedence contexts and associativity
156 # deparse() calls each per-op subroutine with an argument $cx (short
157 # for context, but not the same as the cx* in the perl core), which is
158 # a number describing the op's parents in terms of precedence, whether
159 # they're inside an expression or at statement level, etc. (see
160 # chart below). When ops with children call deparse on them, they pass
161 # along their precedence. Fractional values are used to implement
162 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
163 # parentheses hacks. The major disadvantage of this scheme is that
164 # it doesn't know about right sides and left sides, so say if you
165 # assign a listop to a variable, it can't tell it's allowed to leave
166 # the parens off the listop.
169 # 26 [TODO] inside interpolation context ("")
170 # 25 left terms and list operators (leftward)
174 # 21 right ! ~ \ and unary + and -
179 # 16 nonassoc named unary operators
180 # 15 nonassoc < > <= >= lt gt le ge
181 # 14 nonassoc == != <=> eq ne cmp
188 # 7 right = += -= *= etc.
190 # 5 nonassoc list operators (rightward)
194 # 1 statement modifiers
197 # Nonprinting characters with special meaning:
198 # \cS - steal parens (see maybe_parens_unop)
199 # \n - newline and indent
200 # \t - increase indent
201 # \b - decrease indent (`outdent')
202 # \f - flush left (no indent)
203 # \cK - kill following semicolon, if any
207 return class($op) eq "NULL";
212 my($gv, $cv, $is_form) = @_;
214 if (!null($cv->START) and is_state($cv->START)) {
215 $seq = $cv->START->cop_seq;
219 push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
224 my $ent = shift @{$self->{'subs_todo'}};
225 my $name = $self->gv_name($ent->[1]);
227 return "format $name =\n"
228 . $self->deparse_format($ent->[1]->FORM). "\n";
230 return "sub $name " . $self->deparse_sub($ent->[1]->CV);
237 if ($op->flags & OPf_KIDS) {
239 for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
240 walk_tree($kid, $sub);
249 $op = shift if null $op;
250 return if !$op or null $op;
253 if ($op->name eq "gv") {
254 my $gv = $self->gv_or_padgv($op);
255 if ($op->next->name eq "entersub") {
256 return if $self->{'subs_done'}{$$gv}++;
257 return if class($gv->CV) eq "SPECIAL";
258 $self->todo($gv, $gv->CV, 0);
259 $self->walk_sub($gv->CV);
260 } elsif ($op->next->name eq "enterwrite"
261 or ($op->next->name eq "rv2gv"
262 and $op->next->next->name eq "enterwrite")) {
263 return if $self->{'forms_done'}{$$gv}++;
264 return if class($gv->FORM) eq "SPECIAL";
265 $self->todo($gv, $gv->FORM, 1);
266 $self->walk_sub($gv->FORM);
276 { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
277 if ($pack eq "main") {
280 $pack = $pack . "::";
283 while (($key, $val) = each %stash) {
284 my $class = class($val);
285 if ($class eq "PV") {
287 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
288 } elsif ($class eq "IV") {
290 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
291 } elsif ($class eq "GV") {
292 if (class($val->CV) ne "SPECIAL") {
293 next if $self->{'subs_done'}{$$val}++;
294 $self->todo($val, $val->CV, 0);
295 $self->walk_sub($val->CV);
297 if (class($val->FORM) ne "SPECIAL") {
298 next if $self->{'forms_done'}{$$val}++;
299 $self->todo($val, $val->FORM, 1);
300 $self->walk_sub($val->FORM);
310 foreach $ar (@{$self->{'protos_todo'}}) {
311 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
312 push @ret, "sub " . $ar->[0] . "$proto;\n";
314 delete $self->{'protos_todo'};
322 while (length($opt = substr($opts, 0, 1))) {
324 $self->{'cuddle'} = " ";
325 $opts = substr($opts, 1);
326 } elsif ($opt eq "i") {
327 $opts =~ s/^i(\d+)//;
328 $self->{'indent_size'} = $1;
329 } elsif ($opt eq "T") {
330 $self->{'use_tabs'} = 1;
331 $opts = substr($opts, 1);
332 } elsif ($opt eq "v") {
333 $opts =~ s/^v([^.]*)(.|$)//;
334 $self->{'ex_const'} = $1;
341 my $self = bless {}, $class;
342 $self->{'subs_todo'} = [];
343 $self->{'curstash'} = "main";
344 $self->{'cuddle'} = "\n";
345 $self->{'indent_size'} = 4;
346 $self->{'use_tabs'} = 0;
347 $self->{'ex_const'} = "'???'";
348 while (my $arg = shift @_) {
349 if (substr($arg, 0, 2) eq "-u") {
350 $self->stash_subs(substr($arg, 2));
351 } elsif ($arg eq "-p") {
352 $self->{'parens'} = 1;
353 } elsif ($arg eq "-l") {
354 $self->{'linenums'} = 1;
355 } elsif ($arg eq "-q") {
356 $self->{'unquote'} = 1;
357 } elsif (substr($arg, 0, 2) eq "-s") {
358 $self->style_opts(substr $arg, 2);
367 my $self = B::Deparse->new(@args);
368 $self->stash_subs("main");
369 $self->{'curcv'} = main_cv;
370 $self->walk_sub(main_cv, main_start);
371 print $self->print_protos;
372 @{$self->{'subs_todo'}} =
373 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
374 print $self->indent($self->deparse(main_root, 0)), "\n"
375 unless null main_root;
377 while (scalar(@{$self->{'subs_todo'}})) {
378 push @text, $self->next_todo;
380 print $self->indent(join("", @text)), "\n" if @text;
387 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
388 return $self->indent($self->deparse_sub(svref_2object($sub)));
394 # cluck if class($op) eq "NULL";
395 # return $self->$ {\("pp_" . $op->name)}($op, $cx);
396 my $meth = "pp_" . $op->name;
397 return $self->$meth($op, $cx);
403 my @lines = split(/\n/, $txt);
408 my $cmd = substr($line, 0, 1);
409 if ($cmd eq "\t" or $cmd eq "\b") {
410 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
411 if ($self->{'use_tabs'}) {
412 $leader = "\t" x ($level / 8) . " " x ($level % 8);
414 $leader = " " x $level;
416 $line = substr($line, 1);
418 if (substr($line, 0, 1) eq "\f") {
419 $line = substr($line, 1); # no indent
421 $line = $leader . $line;
425 return join("\n", @lines);
432 if ($cv->FLAGS & SVf_POK) {
433 $proto = "(". $cv->PV . ") ";
435 local($self->{'curcv'}) = $cv;
436 local($self->{'curstash'}) = $self->{'curstash'};
437 if (not null $cv->ROOT) {
439 return $proto . "{\n\t" .
440 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
442 return $proto . "{}\n";
450 local($self->{'curcv'}) = $form;
451 local($self->{'curstash'}) = $self->{'curstash'};
452 my $op = $form->ROOT;
454 $op = $op->first->first; # skip leavewrite, lineseq
455 while (not null $op) {
456 $op = $op->sibling; # skip nextstate
458 $kid = $op->first->sibling; # skip pushmark
459 push @text, $self->const_sv($kid)->PV;
460 $kid = $kid->sibling;
461 for (; not null $kid; $kid = $kid->sibling) {
462 push @exprs, $self->deparse($kid, 0);
464 push @text, join(", ", @exprs)."\n" if @exprs;
467 return join("", @text) . ".";
472 return $op->name eq "leave" || $op->name eq "scope"
473 || $op->name eq "lineseq"
474 || ($op->name eq "null" && class($op) eq "UNOP"
475 && (is_scope($op->first) || $op->first->name eq "enter"));
479 my $name = $_[0]->name;
480 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
483 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
485 return (!null($op) and null($op->sibling)
486 and $op->name eq "null" and class($op) eq "UNOP"
487 and (($op->first->name =~ /^(and|or)$/
488 and $op->first->first->sibling->name eq "lineseq")
489 or ($op->first->name eq "lineseq"
490 and not null $op->first->first->sibling
491 and $op->first->first->sibling->name eq "unstack")
497 return ($op->name eq "rv2sv" or
498 $op->name eq "padsv" or
499 $op->name eq "gv" or # only in array/hash constructs
500 $op->flags & OPf_KIDS && !null($op->first)
501 && $op->first->name eq "gvsv");
506 my($text, $cx, $prec) = @_;
507 if ($prec < $cx # unary ops nest just fine
508 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
509 or $self->{'parens'})
512 # In a unop, let parent reuse our parens; see maybe_parens_unop
513 $text = "\cS" . $text if $cx == 16;
520 # same as above, but get around the `if it looks like a function' rule
521 sub maybe_parens_unop {
523 my($name, $kid, $cx) = @_;
524 if ($cx > 16 or $self->{'parens'}) {
525 return "$name(" . $self->deparse($kid, 1) . ")";
527 $kid = $self->deparse($kid, 16);
528 if (substr($kid, 0, 1) eq "\cS") {
530 return $name . substr($kid, 1);
531 } elsif (substr($kid, 0, 1) eq "(") {
532 # avoid looks-like-a-function trap with extra parens
533 # (`+' can lead to ambiguities)
534 return "$name(" . $kid . ")";
541 sub maybe_parens_func {
543 my($func, $text, $cx, $prec) = @_;
544 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
545 return "$func($text)";
547 return "$func $text";
553 my($op, $cx, $text) = @_;
554 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
555 return $self->maybe_parens_func("local", $text, $cx, 16);
563 my($op, $cx, $func, @args) = @_;
564 if ($op->private & OPpTARGET_MY) {
565 my $var = $self->padname($op->targ);
566 my $val = $func->($self, $op, 7, @args);
567 return $self->maybe_parens("$var = $val", $cx, 7);
569 return $func->($self, $op, $cx, @args);
576 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
581 my($op, $cx, $text) = @_;
582 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
583 return $self->maybe_parens_func("my", $text, $cx, 16);
589 # The following OPs don't have functions:
591 # pp_padany -- does not exist after parsing
592 # pp_rcatline -- does not exist
594 sub pp_enter { # see also leave
595 cluck "unexpected OP_ENTER";
599 sub pp_pushmark { # see also list
600 cluck "unexpected OP_PUSHMARK";
604 sub pp_leavesub { # see also deparse_sub
605 cluck "unexpected OP_LEAVESUB";
609 sub pp_leavewrite { # see also deparse_format
610 cluck "unexpected OP_LEAVEWRITE";
614 sub pp_method { # see also entersub
615 cluck "unexpected OP_METHOD";
619 sub pp_regcmaybe { # see also regcomp
620 cluck "unexpected OP_REGCMAYBE";
624 sub pp_regcreset { # see also regcomp
625 cluck "unexpected OP_REGCRESET";
629 sub pp_substcont { # see also subst
630 cluck "unexpected OP_SUBSTCONT";
634 sub pp_grepstart { # see also grepwhile
635 cluck "unexpected OP_GREPSTART";
639 sub pp_mapstart { # see also mapwhile
640 cluck "unexpected OP_MAPSTART";
644 sub pp_flip { # see also flop
645 cluck "unexpected OP_FLIP";
649 sub pp_iter { # see also leaveloop
650 cluck "unexpected OP_ITER";
654 sub pp_enteriter { # see also leaveloop
655 cluck "unexpected OP_ENTERITER";
659 sub pp_enterloop { # see also leaveloop
660 cluck "unexpected OP_ENTERLOOP";
664 sub pp_leaveeval { # see also entereval
665 cluck "unexpected OP_LEAVEEVAL";
669 sub pp_entertry { # see also leavetry
670 cluck "unexpected OP_ENTERTRY";
674 # leave and scope/lineseq should probably share code
680 local($self->{'curstash'}) = $self->{'curstash'};
681 $kid = $op->first->sibling; # skip enter
682 if (is_miniwhile($kid)) {
683 my $top = $kid->first;
684 my $name = $top->name;
685 if ($name eq "and") {
687 } elsif ($name eq "or") {
689 } else { # no conditional -> while 1 or until 0
690 return $self->deparse($top->first, 1) . " while 1";
692 my $cond = $top->first;
693 my $body = $cond->sibling->first; # skip lineseq
694 $cond = $self->deparse($cond, 1);
695 $body = $self->deparse($body, 1);
696 return "$body $name $cond";
698 for (; !null($kid); $kid = $kid->sibling) {
701 $expr = $self->deparse($kid, 0);
702 $kid = $kid->sibling;
705 $expr .= $self->deparse($kid, 0);
706 push @exprs, $expr if length $expr;
708 if ($cx > 0) { # inside an expression
709 return "do { " . join(";\n", @exprs) . " }";
711 return join(";\n", @exprs) . ";";
720 for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
723 $expr = $self->deparse($kid, 0);
724 $kid = $kid->sibling;
727 $expr .= $self->deparse($kid, 0);
728 push @exprs, $expr if length $expr;
730 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
731 return "do { " . join(";\n", @exprs) . " }";
733 return join(";\n", @exprs) . ";";
737 sub pp_lineseq { pp_scope(@_) }
739 # The BEGIN {} is used here because otherwise this code isn't executed
740 # when you run B::Deparse on itself.
742 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
743 "ENV", "ARGV", "ARGVOUT", "_"); }
748 my $stash = $gv->STASH->NAME;
749 my $name = $gv->NAME;
750 if ($stash eq $self->{'curstash'} or $globalnames{$name}
751 or $name =~ /^[^A-Za-z_]/)
755 $stash = $stash . "::";
757 if ($name =~ /^([\cA-\cZ])$/) {
758 $name = "^" . chr(64 + ord($1));
760 return $stash . $name;
763 # Notice how subs and formats are inserted between statements here
768 @text = $op->label . ": " if $op->label;
769 my $seq = $op->cop_seq;
770 while (scalar(@{$self->{'subs_todo'}})
771 and $seq > $self->{'subs_todo'}[0][0]) {
772 push @text, $self->next_todo;
774 my $stash = $op->stashpv;
775 if ($stash ne $self->{'curstash'}) {
776 push @text, "package $stash;\n";
777 $self->{'curstash'} = $stash;
779 if ($self->{'linenums'}) {
780 push @text, "\f#line " . $op->line .
781 ' "' . $op->file, qq'"\n';
783 return join("", @text);
786 sub pp_dbstate { pp_nextstate(@_) }
787 sub pp_setstate { pp_nextstate(@_) }
789 sub pp_unstack { return "" } # see also leaveloop
793 my($op, $cx, $name) = @_;
797 sub pp_stub { baseop(@_, "()") }
798 sub pp_wantarray { baseop(@_, "wantarray") }
799 sub pp_fork { baseop(@_, "fork") }
800 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
801 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
802 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
803 sub pp_tms { baseop(@_, "times") }
804 sub pp_ghostent { baseop(@_, "gethostent") }
805 sub pp_gnetent { baseop(@_, "getnetent") }
806 sub pp_gprotoent { baseop(@_, "getprotoent") }
807 sub pp_gservent { baseop(@_, "getservent") }
808 sub pp_ehostent { baseop(@_, "endhostent") }
809 sub pp_enetent { baseop(@_, "endnetent") }
810 sub pp_eprotoent { baseop(@_, "endprotoent") }
811 sub pp_eservent { baseop(@_, "endservent") }
812 sub pp_gpwent { baseop(@_, "getpwent") }
813 sub pp_spwent { baseop(@_, "setpwent") }
814 sub pp_epwent { baseop(@_, "endpwent") }
815 sub pp_ggrent { baseop(@_, "getgrent") }
816 sub pp_sgrent { baseop(@_, "setgrent") }
817 sub pp_egrent { baseop(@_, "endgrent") }
818 sub pp_getlogin { baseop(@_, "getlogin") }
822 # I couldn't think of a good short name, but this is the category of
823 # symbolic unary operators with interesting precedence
827 my($op, $cx, $name, $prec, $flags) = (@_, 0);
828 my $kid = $op->first;
829 $kid = $self->deparse($kid, $prec);
830 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
834 sub pp_preinc { pfixop(@_, "++", 23) }
835 sub pp_predec { pfixop(@_, "--", 23) }
836 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
837 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
838 sub pp_i_preinc { pfixop(@_, "++", 23) }
839 sub pp_i_predec { pfixop(@_, "--", 23) }
840 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
841 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
842 sub pp_complement { maybe_targmy(@_. \&pfixop, "~", 21) }
844 sub pp_negate { maybe_targmy(@_, \&real_negate) }
848 if ($op->first->name =~ /^(i_)?negate$/) {
850 $self->pfixop($op, $cx, "-", 21.5);
852 $self->pfixop($op, $cx, "-", 21);
855 sub pp_i_negate { pp_negate(@_) }
861 $self->pfixop($op, $cx, "not ", 4);
863 $self->pfixop($op, $cx, "!", 21);
869 my($op, $cx, $name) = @_;
871 if ($op->flags & OPf_KIDS) {
873 return $self->maybe_parens_unop($name, $kid, $cx);
875 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
879 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
880 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
881 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
882 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
883 sub pp_defined { unop(@_, "defined") }
884 sub pp_undef { unop(@_, "undef") }
885 sub pp_study { unop(@_, "study") }
886 sub pp_ref { unop(@_, "ref") }
887 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
889 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
890 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
891 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
892 sub pp_srand { unop(@_, "srand") }
893 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
894 sub pp_log { maybe_targmy(@_, \&unop, "log") }
895 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
896 sub pp_int { maybe_targmy(@_, \&unop, "int") }
897 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
898 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
899 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
901 sub pp_length { maybe_targmy(@_, \&unop, "length") }
902 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
903 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
905 sub pp_each { unop(@_, "each") }
906 sub pp_values { unop(@_, "values") }
907 sub pp_keys { unop(@_, "keys") }
908 sub pp_pop { unop(@_, "pop") }
909 sub pp_shift { unop(@_, "shift") }
911 sub pp_caller { unop(@_, "caller") }
912 sub pp_reset { unop(@_, "reset") }
913 sub pp_exit { unop(@_, "exit") }
914 sub pp_prototype { unop(@_, "prototype") }
916 sub pp_close { unop(@_, "close") }
917 sub pp_fileno { unop(@_, "fileno") }
918 sub pp_umask { unop(@_, "umask") }
919 sub pp_binmode { unop(@_, "binmode") }
920 sub pp_untie { unop(@_, "untie") }
921 sub pp_tied { unop(@_, "tied") }
922 sub pp_dbmclose { unop(@_, "dbmclose") }
923 sub pp_getc { unop(@_, "getc") }
924 sub pp_eof { unop(@_, "eof") }
925 sub pp_tell { unop(@_, "tell") }
926 sub pp_getsockname { unop(@_, "getsockname") }
927 sub pp_getpeername { unop(@_, "getpeername") }
929 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
930 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
931 sub pp_readlink { unop(@_, "readlink") }
932 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
933 sub pp_readdir { unop(@_, "readdir") }
934 sub pp_telldir { unop(@_, "telldir") }
935 sub pp_rewinddir { unop(@_, "rewinddir") }
936 sub pp_closedir { unop(@_, "closedir") }
937 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
938 sub pp_localtime { unop(@_, "localtime") }
939 sub pp_gmtime { unop(@_, "gmtime") }
940 sub pp_alarm { unop(@_, "alarm") }
941 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
943 sub pp_dofile { unop(@_, "do") }
944 sub pp_entereval { unop(@_, "eval") }
946 sub pp_ghbyname { unop(@_, "gethostbyname") }
947 sub pp_gnbyname { unop(@_, "getnetbyname") }
948 sub pp_gpbyname { unop(@_, "getprotobyname") }
949 sub pp_shostent { unop(@_, "sethostent") }
950 sub pp_snetent { unop(@_, "setnetent") }
951 sub pp_sprotoent { unop(@_, "setprotoent") }
952 sub pp_sservent { unop(@_, "setservent") }
953 sub pp_gpwnam { unop(@_, "getpwnam") }
954 sub pp_gpwuid { unop(@_, "getpwuid") }
955 sub pp_ggrnam { unop(@_, "getgrnam") }
956 sub pp_ggrgid { unop(@_, "getgrgid") }
958 sub pp_lock { unop(@_, "lock") }
963 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
971 if ($op->private & OPpSLICE) {
972 return $self->maybe_parens_func("delete",
973 $self->pp_hslice($op->first, 16),
976 return $self->maybe_parens_func("delete",
977 $self->pp_helem($op->first, 16),
985 if (class($op) eq "UNOP" and $op->first->name eq "const"
986 and $op->first->private & OPpCONST_BARE)
988 my $name = $self->const_sv($op->first)->PV;
991 return "require($name)";
993 $self->unop($op, $cx, "require");
1000 my $kid = $op->first;
1001 if (not null $kid->sibling) {
1002 # XXX Was a here-doc
1003 return $self->dquote($op);
1005 $self->unop(@_, "scalar");
1012 #cluck "curcv was undef" unless $self->{curcv};
1013 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1019 my $kid = $op->first;
1020 if ($kid->name eq "null") {
1022 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1023 my($pre, $post) = @{{"anonlist" => ["[","]"],
1024 "anonhash" => ["{","}"]}->{$kid->name}};
1026 $kid = $kid->first->sibling; # skip pushmark
1027 for (; !null($kid); $kid = $kid->sibling) {
1028 $expr = $self->deparse($kid, 6);
1031 return $pre . join(", ", @exprs) . $post;
1032 } elsif (!null($kid->sibling) and
1033 $kid->sibling->name eq "anoncode") {
1035 $self->deparse_sub($self->padval($kid->sibling->targ));
1036 } elsif ($kid->name eq "pushmark") {
1037 my $sib_name = $kid->sibling->name;
1038 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1039 and not $kid->sibling->flags & OPf_REF)
1041 # The @a in \(@a) isn't in ref context, but only when the
1043 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1044 } elsif ($sib_name eq 'entersub') {
1045 my $text = $self->deparse($kid->sibling, 1);
1046 # Always show parens for \(&func()), but only with -p otherwise
1047 $text = "($text)" if $self->{'parens'}
1048 or $kid->sibling->private & OPpENTERSUB_AMPER;
1053 $self->pfixop($op, $cx, "\\", 20);
1056 sub pp_srefgen { pp_refgen(@_) }
1061 my $kid = $op->first;
1062 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1063 return "<" . $self->deparse($kid, 1) . ">";
1066 # Unary operators that can occur as pseudo-listops inside double quotes
1069 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1071 if ($op->flags & OPf_KIDS) {
1073 # If there's more than one kid, the first is an ex-pushmark.
1074 $kid = $kid->sibling if not null $kid->sibling;
1075 return $self->maybe_parens_unop($name, $kid, $cx);
1077 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1081 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1082 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1083 sub pp_uc { dq_unop(@_, "uc") }
1084 sub pp_lc { dq_unop(@_, "lc") }
1085 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1089 my ($op, $cx, $name) = @_;
1090 if (class($op) eq "PVOP") {
1091 return "$name " . $op->pv;
1092 } elsif (class($op) eq "OP") {
1094 } elsif (class($op) eq "UNOP") {
1095 # Note -- loop exits are actually exempt from the
1096 # looks-like-a-func rule, but a few extra parens won't hurt
1097 return $self->maybe_parens_unop($name, $op->first, $cx);
1101 sub pp_last { loopex(@_, "last") }
1102 sub pp_next { loopex(@_, "next") }
1103 sub pp_redo { loopex(@_, "redo") }
1104 sub pp_goto { loopex(@_, "goto") }
1105 sub pp_dump { loopex(@_, "dump") }
1109 my($op, $cx, $name) = @_;
1110 if (class($op) eq "UNOP") {
1111 # Genuine `-X' filetests are exempt from the LLAFR, but not
1112 # l?stat(); for the sake of clarity, give'em all parens
1113 return $self->maybe_parens_unop($name, $op->first, $cx);
1114 } elsif (class($op) eq "SVOP") {
1115 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1116 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1121 sub pp_lstat { ftst(@_, "lstat") }
1122 sub pp_stat { ftst(@_, "stat") }
1123 sub pp_ftrread { ftst(@_, "-R") }
1124 sub pp_ftrwrite { ftst(@_, "-W") }
1125 sub pp_ftrexec { ftst(@_, "-X") }
1126 sub pp_fteread { ftst(@_, "-r") }
1127 sub pp_ftewrite { ftst(@_, "-r") }
1128 sub pp_fteexec { ftst(@_, "-r") }
1129 sub pp_ftis { ftst(@_, "-e") }
1130 sub pp_fteowned { ftst(@_, "-O") }
1131 sub pp_ftrowned { ftst(@_, "-o") }
1132 sub pp_ftzero { ftst(@_, "-z") }
1133 sub pp_ftsize { ftst(@_, "-s") }
1134 sub pp_ftmtime { ftst(@_, "-M") }
1135 sub pp_ftatime { ftst(@_, "-A") }
1136 sub pp_ftctime { ftst(@_, "-C") }
1137 sub pp_ftsock { ftst(@_, "-S") }
1138 sub pp_ftchr { ftst(@_, "-c") }
1139 sub pp_ftblk { ftst(@_, "-b") }
1140 sub pp_ftfile { ftst(@_, "-f") }
1141 sub pp_ftdir { ftst(@_, "-d") }
1142 sub pp_ftpipe { ftst(@_, "-p") }
1143 sub pp_ftlink { ftst(@_, "-l") }
1144 sub pp_ftsuid { ftst(@_, "-u") }
1145 sub pp_ftsgid { ftst(@_, "-g") }
1146 sub pp_ftsvtx { ftst(@_, "-k") }
1147 sub pp_fttty { ftst(@_, "-t") }
1148 sub pp_fttext { ftst(@_, "-T") }
1149 sub pp_ftbinary { ftst(@_, "-B") }
1151 sub SWAP_CHILDREN () { 1 }
1152 sub ASSIGN () { 2 } # has OP= variant
1158 my $name = $op->name;
1159 if ($name eq "concat" and $op->first->name eq "concat") {
1160 # avoid spurious `=' -- see comment in pp_concat
1163 if ($name eq "null" and class($op) eq "UNOP"
1164 and $op->first->name =~ /^(and|x?or)$/
1165 and null $op->first->sibling)
1167 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1168 # with a null that's used as the common end point of the two
1169 # flows of control. For precedence purposes, ignore it.
1170 # (COND_EXPRs have these too, but we don't bother with
1171 # their associativity).
1172 return assoc_class($op->first);
1174 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1177 # Left associative operators, like `+', for which
1178 # $a + $b + $c is equivalent to ($a + $b) + $c
1181 %left = ('multiply' => 19, 'i_multiply' => 19,
1182 'divide' => 19, 'i_divide' => 19,
1183 'modulo' => 19, 'i_modulo' => 19,
1185 'add' => 18, 'i_add' => 18,
1186 'subtract' => 18, 'i_subtract' => 18,
1188 'left_shift' => 17, 'right_shift' => 17,
1190 'bit_or' => 12, 'bit_xor' => 12,
1192 'or' => 2, 'xor' => 2,
1196 sub deparse_binop_left {
1198 my($op, $left, $prec) = @_;
1199 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1200 and $left{assoc_class($op)} == $left{assoc_class($left)})
1202 return $self->deparse($left, $prec - .00001);
1204 return $self->deparse($left, $prec);
1208 # Right associative operators, like `=', for which
1209 # $a = $b = $c is equivalent to $a = ($b = $c)
1212 %right = ('pow' => 22,
1213 'sassign=' => 7, 'aassign=' => 7,
1214 'multiply=' => 7, 'i_multiply=' => 7,
1215 'divide=' => 7, 'i_divide=' => 7,
1216 'modulo=' => 7, 'i_modulo=' => 7,
1218 'add=' => 7, 'i_add=' => 7,
1219 'subtract=' => 7, 'i_subtract=' => 7,
1221 'left_shift=' => 7, 'right_shift=' => 7,
1223 'bit_or=' => 7, 'bit_xor=' => 7,
1229 sub deparse_binop_right {
1231 my($op, $right, $prec) = @_;
1232 if ($right{assoc_class($op)} && $right{assoc_class($right)}
1233 and $right{assoc_class($op)} == $right{assoc_class($right)})
1235 return $self->deparse($right, $prec - .00001);
1237 return $self->deparse($right, $prec);
1243 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1244 my $left = $op->first;
1245 my $right = $op->last;
1247 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1251 if ($flags & SWAP_CHILDREN) {
1252 ($left, $right) = ($right, $left);
1254 $left = $self->deparse_binop_left($op, $left, $prec);
1255 $right = $self->deparse_binop_right($op, $right, $prec);
1256 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1259 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1260 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1261 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1262 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1263 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1264 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1265 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1266 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1267 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1268 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1269 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1271 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1272 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1273 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1274 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1275 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1277 sub pp_eq { binop(@_, "==", 14) }
1278 sub pp_ne { binop(@_, "!=", 14) }
1279 sub pp_lt { binop(@_, "<", 15) }
1280 sub pp_gt { binop(@_, ">", 15) }
1281 sub pp_ge { binop(@_, ">=", 15) }
1282 sub pp_le { binop(@_, "<=", 15) }
1283 sub pp_ncmp { binop(@_, "<=>", 14) }
1284 sub pp_i_eq { binop(@_, "==", 14) }
1285 sub pp_i_ne { binop(@_, "!=", 14) }
1286 sub pp_i_lt { binop(@_, "<", 15) }
1287 sub pp_i_gt { binop(@_, ">", 15) }
1288 sub pp_i_ge { binop(@_, ">=", 15) }
1289 sub pp_i_le { binop(@_, "<=", 15) }
1290 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1292 sub pp_seq { binop(@_, "eq", 14) }
1293 sub pp_sne { binop(@_, "ne", 14) }
1294 sub pp_slt { binop(@_, "lt", 15) }
1295 sub pp_sgt { binop(@_, "gt", 15) }
1296 sub pp_sge { binop(@_, "ge", 15) }
1297 sub pp_sle { binop(@_, "le", 15) }
1298 sub pp_scmp { binop(@_, "cmp", 14) }
1300 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1301 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1303 # `.' is special because concats-of-concats are optimized to save copying
1304 # by making all but the first concat stacked. The effect is as if the
1305 # programmer had written `($a . $b) .= $c', except legal.
1306 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1310 my $left = $op->first;
1311 my $right = $op->last;
1314 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1318 $left = $self->deparse_binop_left($op, $left, $prec);
1319 $right = $self->deparse_binop_right($op, $right, $prec);
1320 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1323 # `x' is weird when the left arg is a list
1327 my $left = $op->first;
1328 my $right = $op->last;
1331 if ($op->flags & OPf_STACKED) {
1335 if (null($right)) { # list repeat; count is inside left-side ex-list
1336 my $kid = $left->first->sibling; # skip pushmark
1338 for (; !null($kid->sibling); $kid = $kid->sibling) {
1339 push @exprs, $self->deparse($kid, 6);
1342 $left = "(" . join(", ", @exprs). ")";
1344 $left = $self->deparse_binop_left($op, $left, $prec);
1346 $right = $self->deparse_binop_right($op, $right, $prec);
1347 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1352 my ($op, $cx, $type) = @_;
1353 my $left = $op->first;
1354 my $right = $left->sibling;
1355 $left = $self->deparse($left, 9);
1356 $right = $self->deparse($right, 9);
1357 return $self->maybe_parens("$left $type $right", $cx, 9);
1363 my $flip = $op->first;
1364 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1365 return $self->range($flip->first, $cx, $type);
1368 # one-line while/until is handled in pp_leave
1372 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1373 my $left = $op->first;
1374 my $right = $op->first->sibling;
1375 if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
1376 $left = $self->deparse($left, 1);
1377 $right = $self->deparse($right, 0);
1378 return "$blockname ($left) {\n\t$right\n\b}\cK";
1379 } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
1380 $right = $self->deparse($right, 1);
1381 $left = $self->deparse($left, 1);
1382 return "$right $blockname $left";
1383 } elsif ($cx > $lowprec and $highop) { # $a && $b
1384 $left = $self->deparse_binop_left($op, $left, $highprec);
1385 $right = $self->deparse_binop_right($op, $right, $highprec);
1386 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1387 } else { # $a and $b
1388 $left = $self->deparse_binop_left($op, $left, $lowprec);
1389 $right = $self->deparse_binop_right($op, $right, $lowprec);
1390 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1394 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1395 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1397 # xor is syntactically a logop, but it's really a binop (contrary to
1398 # old versions of opcode.pl). Syntax is what matters here.
1399 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1403 my ($op, $cx, $opname) = @_;
1404 my $left = $op->first;
1405 my $right = $op->first->sibling->first; # skip sassign
1406 $left = $self->deparse($left, 7);
1407 $right = $self->deparse($right, 7);
1408 return $self->maybe_parens("$left $opname $right", $cx, 7);
1411 sub pp_andassign { logassignop(@_, "&&=") }
1412 sub pp_orassign { logassignop(@_, "||=") }
1416 my($op, $cx, $name) = @_;
1418 my $parens = ($cx >= 5) || $self->{'parens'};
1419 my $kid = $op->first->sibling;
1420 return $name if null $kid;
1421 my $first = $self->deparse($kid, 6);
1422 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1423 push @exprs, $first;
1424 $kid = $kid->sibling;
1425 for (; !null($kid); $kid = $kid->sibling) {
1426 push @exprs, $self->deparse($kid, 6);
1429 return "$name(" . join(", ", @exprs) . ")";
1431 return "$name " . join(", ", @exprs);
1435 sub pp_bless { listop(@_, "bless") }
1436 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
1437 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1438 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1439 sub pp_index { maybe_targmy(@_, \&listop, "index") }
1440 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
1441 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
1442 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1443 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
1444 sub pp_unpack { listop(@_, "unpack") }
1445 sub pp_pack { listop(@_, "pack") }
1446 sub pp_join { maybe_targmy(@_, \&listop, "join") }
1447 sub pp_splice { listop(@_, "splice") }
1448 sub pp_push { maybe_targmy(@_, \&listop, "push") }
1449 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
1450 sub pp_reverse { listop(@_, "reverse") }
1451 sub pp_warn { listop(@_, "warn") }
1452 sub pp_die { listop(@_, "die") }
1453 # Actually, return is exempt from the LLAFR (see examples in this very
1454 # module!), but for consistency's sake, ignore that fact
1455 sub pp_return { listop(@_, "return") }
1456 sub pp_open { listop(@_, "open") }
1457 sub pp_pipe_op { listop(@_, "pipe") }
1458 sub pp_tie { listop(@_, "tie") }
1459 sub pp_dbmopen { listop(@_, "dbmopen") }
1460 sub pp_sselect { listop(@_, "select") }
1461 sub pp_select { listop(@_, "select") }
1462 sub pp_read { listop(@_, "read") }
1463 sub pp_sysopen { listop(@_, "sysopen") }
1464 sub pp_sysseek { listop(@_, "sysseek") }
1465 sub pp_sysread { listop(@_, "sysread") }
1466 sub pp_syswrite { listop(@_, "syswrite") }
1467 sub pp_send { listop(@_, "send") }
1468 sub pp_recv { listop(@_, "recv") }
1469 sub pp_seek { listop(@_, "seek") }
1470 sub pp_fcntl { listop(@_, "fcntl") }
1471 sub pp_ioctl { listop(@_, "ioctl") }
1472 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
1473 sub pp_socket { listop(@_, "socket") }
1474 sub pp_sockpair { listop(@_, "sockpair") }
1475 sub pp_bind { listop(@_, "bind") }
1476 sub pp_connect { listop(@_, "connect") }
1477 sub pp_listen { listop(@_, "listen") }
1478 sub pp_accept { listop(@_, "accept") }
1479 sub pp_shutdown { listop(@_, "shutdown") }
1480 sub pp_gsockopt { listop(@_, "getsockopt") }
1481 sub pp_ssockopt { listop(@_, "setsockopt") }
1482 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
1483 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
1484 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
1485 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
1486 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
1487 sub pp_link { maybe_targmy(@_, \&listop, "link") }
1488 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
1489 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
1490 sub pp_open_dir { listop(@_, "opendir") }
1491 sub pp_seekdir { listop(@_, "seekdir") }
1492 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
1493 sub pp_system { maybe_targmy(@_, \&listop, "system") }
1494 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
1495 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
1496 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
1497 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
1498 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
1499 sub pp_shmget { listop(@_, "shmget") }
1500 sub pp_shmctl { listop(@_, "shmctl") }
1501 sub pp_shmread { listop(@_, "shmread") }
1502 sub pp_shmwrite { listop(@_, "shmwrite") }
1503 sub pp_msgget { listop(@_, "msgget") }
1504 sub pp_msgctl { listop(@_, "msgctl") }
1505 sub pp_msgsnd { listop(@_, "msgsnd") }
1506 sub pp_msgrcv { listop(@_, "msgrcv") }
1507 sub pp_semget { listop(@_, "semget") }
1508 sub pp_semctl { listop(@_, "semctl") }
1509 sub pp_semop { listop(@_, "semop") }
1510 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1511 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1512 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1513 sub pp_gsbyname { listop(@_, "getservbyname") }
1514 sub pp_gsbyport { listop(@_, "getservbyport") }
1515 sub pp_syscall { listop(@_, "syscall") }
1520 my $text = $self->dq($op->first->sibling); # skip pushmark
1521 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1522 or $text =~ /[<>]/) {
1523 return 'glob(' . single_delim('qq', '"', $text) . ')';
1525 return '<' . $text . '>';
1529 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1530 # be a filehandle. This could probably be better fixed in the core
1531 # by moving the GV lookup into ck_truc.
1537 my $parens = ($cx >= 5) || $self->{'parens'};
1538 my $kid = $op->first->sibling;
1540 if ($op->flags & OPf_SPECIAL) {
1541 # $kid is an OP_CONST
1542 $fh = $self->const_sv($kid)->PV;
1544 $fh = $self->deparse($kid, 6);
1545 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1547 my $len = $self->deparse($kid->sibling, 6);
1549 return "truncate($fh, $len)";
1551 return "truncate $fh, $len";
1557 my($op, $cx, $name) = @_;
1559 my $kid = $op->first->sibling;
1561 if ($op->flags & OPf_STACKED) {
1563 $indir = $indir->first; # skip rv2gv
1564 if (is_scope($indir)) {
1565 $indir = "{" . $self->deparse($indir, 0) . "}";
1567 $indir = $self->deparse($indir, 24);
1569 $indir = $indir . " ";
1570 $kid = $kid->sibling;
1572 for (; !null($kid); $kid = $kid->sibling) {
1573 $expr = $self->deparse($kid, 6);
1576 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
1580 sub pp_prtf { indirop(@_, "printf") }
1581 sub pp_print { indirop(@_, "print") }
1582 sub pp_sort { indirop(@_, "sort") }
1586 my($op, $cx, $name) = @_;
1588 my $kid = $op->first; # this is the (map|grep)start
1589 $kid = $kid->first->sibling; # skip a pushmark
1590 my $code = $kid->first; # skip a null
1591 if (is_scope $code) {
1592 $code = "{" . $self->deparse($code, 0) . "} ";
1594 $code = $self->deparse($code, 24) . ", ";
1596 $kid = $kid->sibling;
1597 for (; !null($kid); $kid = $kid->sibling) {
1598 $expr = $self->deparse($kid, 6);
1599 push @exprs, $expr if $expr;
1601 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1604 sub pp_mapwhile { mapop(@_, "map") }
1605 sub pp_grepwhile { mapop(@_, "grep") }
1611 my $kid = $op->first->sibling; # skip pushmark
1613 my $local = "either"; # could be local(...) or my(...)
1614 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1615 # This assumes that no other private flags equal 128, and that
1616 # OPs that store things other than flags in their op_private,
1617 # like OP_AELEMFAST, won't be immediate children of a list.
1618 unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
1620 $local = ""; # or not
1623 if ($lop->name =~ /^pad[ash]v$/) { # my()
1624 ($local = "", last) if $local eq "local";
1626 } elsif ($lop->name ne "undef") { # local()
1627 ($local = "", last) if $local eq "my";
1631 $local = "" if $local eq "either"; # no point if it's all undefs
1632 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
1633 for (; !null($kid); $kid = $kid->sibling) {
1635 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
1640 $self->{'avoid_local'}{$$lop}++;
1641 $expr = $self->deparse($kid, 6);
1642 delete $self->{'avoid_local'}{$$lop};
1644 $expr = $self->deparse($kid, 6);
1649 return "$local(" . join(", ", @exprs) . ")";
1651 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1655 sub is_ifelse_cont {
1657 return ($op->name eq "null" and class($op) eq "UNOP"
1658 and $op->first->name =~ /^(and|cond_expr)$/
1659 and is_scope($op->first->first->sibling));
1665 my $cond = $op->first;
1666 my $true = $cond->sibling;
1667 my $false = $true->sibling;
1668 my $cuddle = $self->{'cuddle'};
1669 unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
1670 (is_scope($false) || is_ifelse_cont($false))) {
1671 $cond = $self->deparse($cond, 8);
1672 $true = $self->deparse($true, 8);
1673 $false = $self->deparse($false, 8);
1674 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1677 $cond = $self->deparse($cond, 1);
1678 $true = $self->deparse($true, 0);
1679 my $head = "if ($cond) {\n\t$true\n\b}";
1681 while (!null($false) and is_ifelse_cont($false)) {
1682 my $newop = $false->first;
1683 my $newcond = $newop->first;
1684 my $newtrue = $newcond->sibling;
1685 $false = $newtrue->sibling; # last in chain is OP_AND => no else
1686 $newcond = $self->deparse($newcond, 1);
1687 $newtrue = $self->deparse($newtrue, 0);
1688 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1690 if (!null($false)) {
1691 $false = $cuddle . "else {\n\t" .
1692 $self->deparse($false, 0) . "\n\b}\cK";
1696 return $head . join($cuddle, "", @elsifs) . $false;
1702 my $enter = $op->first;
1703 my $kid = $enter->sibling;
1704 local($self->{'curstash'}) = $self->{'curstash'};
1707 if ($kid->name eq "lineseq") { # bare or infinite loop
1708 if (is_state $kid->last) { # infinite
1709 $head = "for (;;) "; # shorter than while (1)
1713 } elsif ($enter->name eq "enteriter") { # foreach
1714 my $ary = $enter->first->sibling; # first was pushmark
1715 my $var = $ary->sibling;
1716 if ($enter->flags & OPf_STACKED
1717 and not null $ary->first->sibling->sibling)
1719 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1720 $self->deparse($ary->first->sibling->sibling, 9);
1722 $ary = $self->deparse($ary, 1);
1725 if ($enter->flags & OPf_SPECIAL) { # thread special var
1726 $var = $self->pp_threadsv($enter, 1);
1727 } else { # regular my() variable
1728 $var = $self->pp_padsv($enter, 1);
1729 if ($self->padname_sv($enter->targ)->IVX ==
1730 $kid->first->first->sibling->last->cop_seq)
1732 # If the scope of this variable closes at the last
1733 # statement of the loop, it must have been
1735 $var = "my " . $var;
1738 } elsif ($var->name eq "rv2gv") {
1739 $var = $self->pp_rv2sv($var, 1);
1740 } elsif ($var->name eq "gv") {
1741 $var = "\$" . $self->deparse($var, 1);
1743 $head = "foreach $var ($ary) ";
1744 $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1745 } elsif ($kid->name eq "null") { # while/until
1747 my $name = {"and" => "while", "or" => "until"}
1749 $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
1750 $kid = $kid->first->sibling;
1751 } elsif ($kid->name eq "stub") { # bare and empty
1752 return "{;}"; # {} could be a hashref
1754 # The third-to-last kid is the continue block if the pointer used
1755 # by `next BLOCK' points to its first OP, which happens to be the
1756 # the op_next of the head of the _previous_ statement.
1757 # Unless it's a bare loop, in which case it's last, since there's
1758 # no unstack or extra nextstate.
1759 # Except if the previous head isn't null but the first kid is
1760 # (because it's a nulled out nextstate in a scope), in which
1761 # case the head's next is advanced past the null but the nextop's
1762 # isn't, so we need to try nextop->next.
1764 my $cont = $kid->first;
1766 while (!null($cont->sibling)) {
1768 $cont = $cont->sibling;
1771 while (!null($cont->sibling->sibling->sibling)) {
1773 $cont = $cont->sibling;
1776 if ($precont and $ {$precont->next} == $ {$enter->nextop}
1777 || $ {$precont->next} == $ {$enter->nextop->next} )
1779 my $state = $kid->first;
1780 my $cuddle = $self->{'cuddle'};
1782 for (; $$state != $$cont; $state = $state->sibling) {
1784 if (is_state $state) {
1785 $expr = $self->deparse($state, 0);
1786 $state = $state->sibling;
1789 $expr .= $self->deparse($state, 0);
1790 push @exprs, $expr if $expr;
1792 $kid = join(";\n", @exprs);
1793 $cont = $cuddle . "continue {\n\t" .
1794 $self->deparse($cont, 0) . "\n\b}\cK";
1797 $kid = $self->deparse($kid, 0);
1799 return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1804 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
1807 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
1808 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
1813 if (class($op) eq "OP") {
1815 return $self->{'ex_const'} if $op->targ == OP_CONST;
1816 } elsif ($op->first->name eq "pushmark") {
1817 return $self->pp_list($op, $cx);
1818 } elsif ($op->first->name eq "enter") {
1819 return $self->pp_leave($op, $cx);
1820 } elsif ($op->targ == OP_STRINGIFY) {
1821 return $self->dquote($op, $cx);
1822 } elsif (!null($op->first->sibling) and
1823 $op->first->sibling->name eq "readline" and
1824 $op->first->sibling->flags & OPf_STACKED) {
1825 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1826 . $self->deparse($op->first->sibling, 7),
1828 } elsif (!null($op->first->sibling) and
1829 $op->first->sibling->name eq "trans" and
1830 $op->first->sibling->flags & OPf_STACKED) {
1831 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1832 . $self->deparse($op->first->sibling, 20),
1835 return $self->deparse($op->first, $cx);
1839 # the aassign in-common check messes up SvCUR (always setting it
1840 # to a value >= 100), but it's probably safe to assume there
1841 # won't be any NULs in the names of my() variables. (with
1842 # stash variables, I wouldn't be so sure)
1845 $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
1852 my $str = $self->padname_sv($targ)->PV;
1853 return padname_fix($str);
1859 return substr($self->padname($op->targ), 1); # skip $/@/%
1865 return $self->maybe_my($op, $cx, $self->padname($op->targ));
1868 sub pp_padav { pp_padsv(@_) }
1869 sub pp_padhv { pp_padsv(@_) }
1874 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1875 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1876 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1883 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
1889 if (class($op) eq "PADOP") {
1890 return $self->padval($op->padix);
1891 } else { # class($op) eq "SVOP"
1899 my $gv = $self->gv_or_padgv($op);
1900 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv));
1906 my $gv = $self->gv_or_padgv($op);
1907 return $self->gv_name($gv);
1913 my $gv = $self->gv_or_padgv($op);
1914 return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1919 my($op, $cx, $type) = @_;
1920 my $kid = $op->first;
1921 my $str = $self->deparse($kid, 0);
1922 return $type . (is_scalar($kid) ? $str : "{$str}");
1925 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1926 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1927 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1933 if ($op->first->name eq "padav") {
1934 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
1936 return $self->maybe_local($op, $cx,
1937 $self->rv2x($op->first, $cx, '$#'));
1941 # skip down to the old, ex-rv2cv
1942 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
1947 my $kid = $op->first;
1948 if ($kid->name eq "const") { # constant list
1949 my $av = $self->const_sv($kid);
1950 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1952 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
1956 sub is_subscriptable {
1958 if ($op->name =~ /^[ahg]elem/) {
1960 } elsif ($op->name eq "entersub") {
1961 my $kid = $op->first;
1962 return 0 unless null $kid->sibling;
1964 $kid = $kid->sibling until null $kid->sibling;
1965 return 0 if is_scope($kid);
1967 return 0 if $kid->name eq "gv";
1968 return 0 if is_scalar($kid);
1969 return is_subscriptable($kid);
1977 my ($op, $cx, $left, $right, $padname) = @_;
1978 my($array, $idx) = ($op->first, $op->first->sibling);
1979 unless ($array->name eq $padname) { # Maybe this has been fixed
1980 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1982 if ($array->name eq $padname) {
1983 $array = $self->padany($array);
1984 } elsif (is_scope($array)) { # ${expr}[0]
1985 $array = "{" . $self->deparse($array, 0) . "}";
1986 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
1987 $array = $self->deparse($array, 24);
1989 # $x[20][3]{hi} or expr->[20]
1990 my $arrow = is_subscriptable($array) ? "" : "->";
1991 return $self->deparse($array, 24) . $arrow .
1992 $left . $self->deparse($idx, 1) . $right;
1994 $idx = $self->deparse($idx, 1);
1995 return "\$" . $array . $left . $idx . $right;
1998 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
1999 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2004 my($glob, $part) = ($op->first, $op->last);
2005 $glob = $glob->first; # skip rv2gv
2006 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2007 my $scope = is_scope($glob);
2008 $glob = $self->deparse($glob, 0);
2009 $part = $self->deparse($part, 1);
2010 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2015 my ($op, $cx, $left, $right, $regname, $padname) = @_;
2017 my(@elems, $kid, $array, $list);
2018 if (class($op) eq "LISTOP") {
2020 } else { # ex-hslice inside delete()
2021 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2025 $array = $array->first
2026 if $array->name eq $regname or $array->name eq "null";
2027 if (is_scope($array)) {
2028 $array = "{" . $self->deparse($array, 0) . "}";
2029 } elsif ($array->name eq $padname) {
2030 $array = $self->padany($array);
2032 $array = $self->deparse($array, 24);
2034 $kid = $op->first->sibling; # skip pushmark
2035 if ($kid->name eq "list") {
2036 $kid = $kid->first->sibling; # skip list, pushmark
2037 for (; !null $kid; $kid = $kid->sibling) {
2038 push @elems, $self->deparse($kid, 6);
2040 $list = join(", ", @elems);
2042 $list = $self->deparse($kid, 1);
2044 return "\@" . $array . $left . $list . $right;
2047 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2048 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2053 my $idx = $op->first;
2054 my $list = $op->last;
2056 $list = $self->deparse($list, 1);
2057 $idx = $self->deparse($idx, 1);
2058 return "($list)" . "[$idx]";
2063 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2068 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2074 my $kid = $op->first->sibling; # skip pushmark
2075 my($meth, $obj, @exprs);
2076 if ($kid->name eq "list" and want_list $kid) {
2077 # When an indirect object isn't a bareword but the args are in
2078 # parens, the parens aren't part of the method syntax (the LLAFR
2079 # doesn't apply), but they make a list with OPf_PARENS set that
2080 # doesn't get flattened by the append_elem that adds the method,
2081 # making a (object, arg1, arg2, ...) list where the object
2082 # usually is. This can be distinguished from
2083 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2084 # object) because in the later the list is in scalar context
2085 # as the left side of -> always is, while in the former
2086 # the list is in list context as method arguments always are.
2087 # (Good thing there aren't method prototypes!)
2088 $meth = $kid->sibling;
2089 $kid = $kid->first->sibling; # skip pushmark
2091 $kid = $kid->sibling;
2092 for (; not null $kid; $kid = $kid->sibling) {
2093 push @exprs, $self->deparse($kid, 6);
2097 $kid = $kid->sibling;
2098 for (; not null $kid->sibling; $kid = $kid->sibling) {
2099 push @exprs, $self->deparse($kid, 6);
2103 $obj = $self->deparse($obj, 24);
2104 if ($meth->name eq "method_named") {
2105 $meth = $self->const_sv($meth)->PV;
2107 $meth = $meth->first;
2108 if ($meth->name eq "const") {
2109 # As of 5.005_58, this case is probably obsoleted by the
2110 # method_named case above
2111 $meth = $self->const_sv($meth)->PV; # needs to be bare
2113 $meth = $self->deparse($meth, 1);
2116 my $args = join(", ", @exprs);
2117 $kid = $obj . "->" . $meth;
2119 return $kid . "(" . $args . ")"; # parens mandatory
2125 # returns "&" if the prototype doesn't match the args,
2126 # or ("", $args_after_prototype_demunging) if it does.
2129 my($proto, @args) = @_;
2133 # An unbackslashed @ or % gobbles up the rest of the args
2134 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2136 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2139 return "&" if @args;
2140 } elsif ($chr eq ";") {
2142 } elsif ($chr eq "@" or $chr eq "%") {
2143 push @reals, map($self->deparse($_, 6), @args);
2149 if (want_scalar $arg) {
2150 push @reals, $self->deparse($arg, 6);
2154 } elsif ($chr eq "&") {
2155 if ($arg->name =~ /^(s?refgen|undef)$/) {
2156 push @reals, $self->deparse($arg, 6);
2160 } elsif ($chr eq "*") {
2161 if ($arg->name =~ /^s?refgen$/
2162 and $arg->first->first->name eq "rv2gv")
2164 $real = $arg->first->first; # skip refgen, null
2165 if ($real->first->name eq "gv") {
2166 push @reals, $self->deparse($real, 6);
2168 push @reals, $self->deparse($real->first, 6);
2173 } elsif (substr($chr, 0, 1) eq "\\") {
2174 $chr = substr($chr, 1);
2175 if ($arg->name =~ /^s?refgen$/ and
2176 !null($real = $arg->first) and
2177 ($chr eq "\$" && is_scalar($real->first)
2179 && $real->first->sibling->name
2182 && $real->first->sibling->name
2184 #or ($chr eq "&" # This doesn't work
2185 # && $real->first->name eq "rv2cv")
2187 && $real->first->name eq "rv2gv")))
2189 push @reals, $self->deparse($real, 6);
2196 return "&" if $proto and !$doneok; # too few args and no `;'
2197 return "&" if @args; # too many args
2198 return ("", join ", ", @reals);
2204 return $self->method($op, $cx) unless null $op->first->sibling;
2208 if ($op->flags & OPf_SPECIAL) {
2210 } elsif ($op->private & OPpENTERSUB_AMPER) {
2214 $kid = $kid->first->sibling; # skip ex-list, pushmark
2215 for (; not null $kid->sibling; $kid = $kid->sibling) {
2220 if (is_scope($kid)) {
2222 $kid = "{" . $self->deparse($kid, 0) . "}";
2223 } elsif ($kid->first->name eq "gv") {
2224 my $gv = $self->gv_or_padgv($kid->first);
2225 if (class($gv->CV) ne "SPECIAL") {
2226 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2228 $simple = 1; # only calls of named functions can be prototyped
2229 $kid = $self->deparse($kid, 24);
2230 } elsif (is_scalar $kid->first) {
2232 $kid = $self->deparse($kid, 24);
2235 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2236 $kid = $self->deparse($kid, 24) . $arrow;
2239 if (defined $proto and not $amper) {
2240 ($amper, $args) = $self->check_proto($proto, @exprs);
2241 if ($amper eq "&") {
2242 $args = join(", ", map($self->deparse($_, 6), @exprs));
2245 $args = join(", ", map($self->deparse($_, 6), @exprs));
2247 if ($prefix or $amper) {
2248 if ($op->flags & OPf_STACKED) {
2249 return $prefix . $amper . $kid . "(" . $args . ")";
2251 return $prefix . $amper. $kid;
2254 if (defined $proto and $proto eq "") {
2256 } elsif (defined $proto and $proto eq "\$") {
2257 return $self->maybe_parens_func($kid, $args, $cx, 16);
2258 } elsif (defined($proto) && $proto or $simple) {
2259 return $self->maybe_parens_func($kid, $args, $cx, 5);
2261 return "$kid(" . $args . ")";
2266 sub pp_enterwrite { unop(@_, "write") }
2268 # escape things that cause interpolation in double quotes,
2269 # but not character escapes
2272 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2276 # the same, but treat $|, $), and $ at the end of the string differently
2279 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2280 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2284 # character escapes, but not delimiters that might need to be escaped
2285 sub escape_str { # ASCII
2288 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2294 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2295 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2299 # Don't do this for regexen
2302 $str =~ s/\\/\\\\/g;
2306 sub balanced_delim {
2308 my @str = split //, $str;
2309 my($ar, $open, $close, $fail, $c, $cnt);
2310 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2311 ($open, $close) = @$ar;
2312 $fail = 0; $cnt = 0;
2316 } elsif ($c eq $close) {
2325 $fail = 1 if $cnt != 0;
2326 return ($open, "$open$str$close") if not $fail;
2332 my($q, $default, $str) = @_;
2333 return "$default$str$default" if $default and index($str, $default) == -1;
2334 my($succeed, $delim);
2335 ($succeed, $str) = balanced_delim($str);
2336 return "$q$str" if $succeed;
2337 for $delim ('/', '"', '#') {
2338 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2341 $str =~ s/$default/\\$default/g;
2342 return "$default$str$default";
2351 if (class($sv) eq "SPECIAL") {
2352 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2353 } elsif ($sv->FLAGS & SVf_IOK) {
2355 } elsif ($sv->FLAGS & SVf_NOK) {
2357 } elsif ($sv->FLAGS & SVf_ROK) {
2358 return "\\(" . const($sv->RV) . ")"; # constant folded
2361 if ($str =~ /[^ -~]/) { # ASCII for non-printing
2362 return single_delim("qq", '"', uninterp escape_str unback $str);
2364 return single_delim("q", "'", unback $str);
2373 # the constant could be in the pad (under useithreads)
2374 $sv = $self->padval($op->targ) unless $$sv;
2381 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2382 # return $self->const_sv($op)->PV;
2384 my $sv = $self->const_sv($op);
2391 my $type = $op->name;
2392 if ($type eq "const") {
2393 return uninterp(escape_str(unback($self->const_sv($op)->PV)));
2394 } elsif ($type eq "concat") {
2395 return $self->dq($op->first) . $self->dq($op->last);
2396 } elsif ($type eq "uc") {
2397 return '\U' . $self->dq($op->first->sibling) . '\E';
2398 } elsif ($type eq "lc") {
2399 return '\L' . $self->dq($op->first->sibling) . '\E';
2400 } elsif ($type eq "ucfirst") {
2401 return '\u' . $self->dq($op->first->sibling);
2402 } elsif ($type eq "lcfirst") {
2403 return '\l' . $self->dq($op->first->sibling);
2404 } elsif ($type eq "quotemeta") {
2405 return '\Q' . $self->dq($op->first->sibling) . '\E';
2406 } elsif ($type eq "join") {
2407 return $self->deparse($op->last, 26); # was join($", @ary)
2409 return $self->deparse($op, 26);
2417 return single_delim("qx", '`', $self->dq($op->first->sibling));
2423 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2424 return $self->deparse($kid, $cx) if $self->{'unquote'};
2425 $self->maybe_targmy($kid, $cx,
2426 sub {single_delim("qq", '"', $self->dq($_[1]))});
2429 # OP_STRINGIFY is a listop, but it only ever has one arg
2430 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2432 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2433 # note that tr(from)/to/ is OK, but not tr/from/(to)
2435 my($from, $to) = @_;
2436 my($succeed, $delim);
2437 if ($from !~ m[/] and $to !~ m[/]) {
2438 return "/$from/$to/";
2439 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2440 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2443 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2444 return "$from$delim$to$delim" if index($to, $delim) == -1;
2447 return "$from/$to/";
2450 for $delim ('/', '"', '#') { # note no '
2451 return "$delim$from$delim$to$delim"
2452 if index($to . $from, $delim) == -1;
2454 $from =~ s[/][\\/]g;
2456 return "/$from/$to/";
2462 if ($n == ord '\\') {
2464 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2466 } elsif ($n == ord "\a") {
2468 } elsif ($n == ord "\b") {
2470 } elsif ($n == ord "\t") {
2472 } elsif ($n == ord "\n") {
2474 } elsif ($n == ord "\e") {
2476 } elsif ($n == ord "\f") {
2478 } elsif ($n == ord "\r") {
2480 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2481 return '\\c' . chr(ord("@") + $n);
2483 # return '\x' . sprintf("%02x", $n);
2484 return '\\' . sprintf("%03o", $n);
2491 for ($c = 0; $c < @chars; $c++) {
2494 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2495 $chars[$c + 2] == $tr + 2)
2497 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
2500 $str .= pchr($chars[$c]);
2506 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
2509 sub tr_decode_byte {
2510 my($table, $flags) = @_;
2511 my(@table) = unpack("s256", $table);
2512 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2513 if ($table[ord "-"] != -1 and
2514 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2516 $tr = $table[ord "-"];
2517 $table[ord "-"] = -1;
2521 } else { # -2 ==> delete
2525 for ($c = 0; $c < 256; $c++) {
2528 push @from, $c; push @to, $tr;
2529 } elsif ($tr == -2) {
2533 @from = (@from, @delfrom);
2534 if ($flags & OPpTRANS_COMPLEMENT) {
2537 @from{@from} = (1) x @from;
2538 for ($c = 0; $c < 256; $c++) {
2539 push @newfrom, $c unless $from{$c};
2543 unless ($flags & OPpTRANS_DELETE) {
2544 pop @to while $#to and $to[$#to] == $to[$#to -1];
2547 $from = collapse(@from);
2548 $to = collapse(@to);
2549 $from .= "-" if $delhyphen;
2550 return ($from, $to);
2555 if ($x == ord "-") {
2562 # XXX This doesn't yet handle all cases correctly either
2564 sub tr_decode_utf8 {
2565 my($swash_hv, $flags) = @_;
2566 my %swash = $swash_hv->ARRAY;
2568 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
2569 my $none = $swash{"NONE"}->IV;
2570 my $extra = $none + 1;
2571 my(@from, @delfrom, @to);
2573 foreach $line (split /\n/, $swash{'LIST'}->PV) {
2574 my($min, $max, $result) = split(/\t/, $line);
2581 $result = hex $result;
2582 if ($result == $extra) {
2583 push @delfrom, [$min, $max];
2585 push @from, [$min, $max];
2586 push @to, [$result, $result + $max - $min];
2589 for my $i (0 .. $#from) {
2590 if ($from[$i][0] == ord '-') {
2591 unshift @from, splice(@from, $i, 1);
2592 unshift @to, splice(@to, $i, 1);
2594 } elsif ($from[$i][1] == ord '-') {
2597 unshift @from, ord '-';
2598 unshift @to, ord '-';
2602 for my $i (0 .. $#delfrom) {
2603 if ($delfrom[$i][0] == ord '-') {
2604 push @delfrom, splice(@delfrom, $i, 1);
2606 } elsif ($delfrom[$i][1] == ord '-') {
2608 push @delfrom, ord '-';
2612 if (defined $final and $to[$#to][1] != $final) {
2613 push @to, [$final, $final];
2615 push @from, @delfrom;
2616 if ($flags & OPpTRANS_COMPLEMENT) {
2619 for my $i (0 .. $#from) {
2620 push @newfrom, [$next, $from[$i][0] - 1];
2621 $next = $from[$i][1] + 1;
2624 for my $range (@newfrom) {
2625 if ($range->[0] <= $range->[1]) {
2630 my($from, $to, $diff);
2631 for my $chunk (@from) {
2632 $diff = $chunk->[1] - $chunk->[0];
2634 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2635 } elsif ($diff == 1) {
2636 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2638 $from .= tr_chr($chunk->[0]);
2641 for my $chunk (@to) {
2642 $diff = $chunk->[1] - $chunk->[0];
2644 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2645 } elsif ($diff == 1) {
2646 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2648 $to .= tr_chr($chunk->[0]);
2651 #$final = sprintf("%04x", $final) if defined $final;
2652 #$none = sprintf("%04x", $none) if defined $none;
2653 #$extra = sprintf("%04x", $extra) if defined $extra;
2654 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
2655 #print STDERR $swash{'LIST'}->PV;
2656 return (escape_str($from), escape_str($to));
2663 if (class($op) eq "PVOP") {
2664 ($from, $to) = tr_decode_byte($op->pv, $op->private);
2665 } else { # class($op) eq "SVOP"
2666 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
2669 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
2670 $flags .= "d" if $op->private & OPpTRANS_DELETE;
2671 $to = "" if $from eq $to and $flags eq "";
2672 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2673 return "tr" . double_delim($from, $to) . $flags;
2676 # Like dq(), but different
2680 my $type = $op->name;
2681 if ($type eq "const") {
2682 return uninterp($self->const_sv($op)->PV);
2683 } elsif ($type eq "concat") {
2684 return $self->re_dq($op->first) . $self->re_dq($op->last);
2685 } elsif ($type eq "uc") {
2686 return '\U' . $self->re_dq($op->first->sibling) . '\E';
2687 } elsif ($type eq "lc") {
2688 return '\L' . $self->re_dq($op->first->sibling) . '\E';
2689 } elsif ($type eq "ucfirst") {
2690 return '\u' . $self->re_dq($op->first->sibling);
2691 } elsif ($type eq "lcfirst") {
2692 return '\l' . $self->re_dq($op->first->sibling);
2693 } elsif ($type eq "quotemeta") {
2694 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2695 } elsif ($type eq "join") {
2696 return $self->deparse($op->last, 26); # was join($", @ary)
2698 return $self->deparse($op, 26);
2705 my $kid = $op->first;
2706 $kid = $kid->first if $kid->name eq "regcmaybe";
2707 $kid = $kid->first if $kid->name eq "regcreset";
2708 return $self->re_dq($kid);
2711 # osmic acid -- see osmium tetroxide
2714 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2715 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2716 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2720 my($op, $cx, $name, $delim) = @_;
2721 my $kid = $op->first;
2722 my ($binop, $var, $re) = ("", "", "");
2723 if ($op->flags & OPf_STACKED) {
2725 $var = $self->deparse($kid, 20);
2726 $kid = $kid->sibling;
2729 $re = re_uninterp(escape_str($op->precomp));
2731 $re = $self->deparse($kid, 1);
2734 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2735 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2736 $flags .= "i" if $op->pmflags & PMf_FOLD;
2737 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2738 $flags .= "o" if $op->pmflags & PMf_KEEP;
2739 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2740 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2741 $flags = $matchwords{$flags} if $matchwords{$flags};
2742 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2746 $re = single_delim($name, $delim, $re);
2750 return $self->maybe_parens("$var =~ $re", $cx, 20);
2756 sub pp_match { matchop(@_, "m", "/") }
2757 sub pp_pushre { matchop(@_, "m", "/") }
2758 sub pp_qr { matchop(@_, "qr", "") }
2763 my($kid, @exprs, $ary, $expr);
2765 if ($ {$kid->pmreplroot}) {
2766 $ary = '@' . $self->gv_name($kid->pmreplroot);
2768 for (; !null($kid); $kid = $kid->sibling) {
2769 push @exprs, $self->deparse($kid, 6);
2771 $expr = "split(" . join(", ", @exprs) . ")";
2773 return $self->maybe_parens("$ary = $expr", $cx, 7);
2779 # oxime -- any of various compounds obtained chiefly by the action of
2780 # hydroxylamine on aldehydes and ketones and characterized by the
2781 # bivalent grouping C=NOH [Webster's Tenth]
2784 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2785 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2786 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2787 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2792 my $kid = $op->first;
2793 my($binop, $var, $re, $repl) = ("", "", "", "");
2794 if ($op->flags & OPf_STACKED) {
2796 $var = $self->deparse($kid, 20);
2797 $kid = $kid->sibling;
2800 if (null($op->pmreplroot)) {
2801 $repl = $self->dq($kid);
2802 $kid = $kid->sibling;
2804 $repl = $op->pmreplroot->first; # skip substcont
2805 while ($repl->name eq "entereval") {
2806 $repl = $repl->first;
2809 if ($op->pmflags & PMf_EVAL) {
2810 $repl = $self->deparse($repl, 0);
2812 $repl = $self->dq($repl);
2816 $re = re_uninterp(escape_str($op->precomp));
2818 $re = $self->deparse($kid, 1);
2820 $flags .= "e" if $op->pmflags & PMf_EVAL;
2821 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2822 $flags .= "i" if $op->pmflags & PMf_FOLD;
2823 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2824 $flags .= "o" if $op->pmflags & PMf_KEEP;
2825 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2826 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2827 $flags = $substwords{$flags} if $substwords{$flags};
2829 return $self->maybe_parens("$var =~ s"
2830 . double_delim($re, $repl) . $flags,
2833 return "s". double_delim($re, $repl) . $flags;
2842 B::Deparse - Perl compiler backend to produce perl code
2846 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>][B<,-s>I<LETTERS>]
2851 B::Deparse is a backend module for the Perl compiler that generates
2852 perl source code, based on the internal compiled structure that perl
2853 itself creates after parsing a program. The output of B::Deparse won't
2854 be exactly the same as the original source, since perl doesn't keep
2855 track of comments or whitespace, and there isn't a one-to-one
2856 correspondence between perl's syntactical constructions and their
2857 compiled form, but it will often be close. When you use the B<-p>
2858 option, the output also includes parentheses even when they are not
2859 required by precedence, which can make it easy to see if perl is
2860 parsing your expressions the way you intended.
2862 Please note that this module is mainly new and untested code and is
2863 still under development, so it may change in the future.
2867 As with all compiler backend options, these must follow directly after
2868 the '-MO=Deparse', separated by a comma but not any white space.
2874 Add '#line' declarations to the output based on the line and file
2875 locations of the original code.
2879 Print extra parentheses. Without this option, B::Deparse includes
2880 parentheses in its output only when they are needed, based on the
2881 structure of your program. With B<-p>, it uses parentheses (almost)
2882 whenever they would be legal. This can be useful if you are used to
2883 LISP, or if you want to see how perl parses your input. If you say
2885 if ($var & 0x7f == 65) {print "Gimme an A!"}
2886 print ($which ? $a : $b), "\n";
2887 $name = $ENV{USER} or "Bob";
2889 C<B::Deparse,-p> will print
2892 print('Gimme an A!')
2894 (print(($which ? $a : $b)), '???');
2895 (($name = $ENV{'USER'}) or '???')
2897 which probably isn't what you intended (the C<'???'> is a sign that
2898 perl optimized away a constant value).
2902 Expand double-quoted strings into the corresponding combinations of
2903 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
2906 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
2910 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
2911 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
2913 Note that the expanded form represents the way perl handles such
2914 constructions internally -- this option actually turns off the reverse
2915 translation that B::Deparse usually does. On the other hand, note that
2916 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
2917 of $y into a string before doing the assignment.
2919 =item B<-u>I<PACKAGE>
2921 Normally, B::Deparse deparses the main code of a program, all the subs
2922 called by the main program (and all the subs called by them,
2923 recursively), and any other subs in the main:: package. To include
2924 subs in other packages that aren't called directly, such as AUTOLOAD,
2925 DESTROY, other subs called automatically by perl, and methods (which
2926 aren't resolved to subs until runtime), use the B<-u> option. The
2927 argument to B<-u> is the name of a package, and should follow directly
2928 after the 'u'. Multiple B<-u> options may be given, separated by
2929 commas. Note that unlike some other backends, B::Deparse doesn't
2930 (yet) try to guess automatically when B<-u> is needed -- you must
2933 =item B<-s>I<LETTERS>
2935 Tweak the style of B::Deparse's output. The letters should follow
2936 directly after the 's', with no space or punctuation. The following
2937 options are available:
2943 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2960 The default is not to cuddle.
2964 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
2968 Use tabs for each 8 columns of indent. The default is to use only spaces.
2969 For instance, if the style options are B<-si4T>, a line that's indented
2970 3 times will be preceded by one tab and four spaces; if the options were
2971 B<-si8T>, the same line would be preceded by three tabs.
2973 =item B<v>I<STRING>B<.>
2975 Print I<STRING> for the value of a constant that can't be determined
2976 because it was optimized away (mnemonic: this happens when a constant
2977 is used in B<v>oid context). The end of the string is marked by a period.
2978 The string should be a valid perl expression, generally a constant.
2979 Note that unless it's a number, it probably needs to be quoted, and on
2980 a command line quotes need to be protected from the shell. Some
2981 conventional values include 0, 1, 42, '', 'foo', and
2982 'Useless use of constant omitted' (which may need to be
2983 B<-sv"'Useless use of constant omitted'.">
2984 or something similar depending on your shell). The default is '???'.
2985 If you're using B::Deparse on a module or other file that's require'd,
2986 you shouldn't use a value that evaluates to false, since the customary
2987 true constant at the end of a module will be in void context when the
2988 file is compiled as a main program.
2994 =head1 USING B::Deparse AS A MODULE
2999 $deparse = B::Deparse->new("-p", "-sC");
3000 $body = $deparse->coderef2text(\&func);
3001 eval "sub func $body"; # the inverse operation
3005 B::Deparse can also be used on a sub-by-sub basis from other perl
3010 $deparse = B::Deparse->new(OPTIONS)
3012 Create an object to store the state of a deparsing operation and any
3013 options. The options are the same as those that can be given on the
3014 command line (see L</OPTIONS>); options that are separated by commas
3015 after B<-MO=Deparse> should be given as separate strings. Some
3016 options, like B<-u>, don't make sense for a single subroutine, so
3021 $body = $deparse->coderef2text(\&func)
3022 $body = $deparse->coderef2text(sub ($$) { ... })
3024 Return source code for the body of a subroutine (a block, optionally
3025 preceded by a prototype in parens), given a reference to the
3026 sub. Because a subroutine can have no names, or more than one name,
3027 this method doesn't return a complete subroutine definition -- if you
3028 want to eval the result, you should prepend "sub subname ", or "sub "
3029 for an anonymous function constructor. Unless the sub was defined in
3030 the main:: package, the code will include a package declaration.
3034 See the 'to do' list at the beginning of the module file.
3038 Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier
3039 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3040 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3041 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.