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 CVf_METHOD CVf_LOCKED CVf_LVALUE
18 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
19 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
23 # Changes between 0.50 and 0.51:
24 # - fixed nulled leave with live enter in sort { }
25 # - fixed reference constants (\"str")
26 # - handle empty programs gracefully
27 # - handle infinte loops (for (;;) {}, while (1) {})
28 # - differentiate between `for my $x ...' and `my $x; for $x ...'
29 # - various minor cleanups
30 # - moved globals into an object
31 # - added `-u', like B::C
32 # - package declarations using cop_stash
33 # - subs, formats and code sorted by cop_seq
34 # Changes between 0.51 and 0.52:
35 # - added pp_threadsv (special variables under USE_THREADS)
36 # - added documentation
37 # Changes between 0.52 and 0.53:
38 # - many changes adding precedence contexts and associativity
39 # - added `-p' and `-s' output style options
40 # - various other minor fixes
41 # Changes between 0.53 and 0.54:
42 # - added support for new `for (1..100)' optimization,
44 # Changes between 0.54 and 0.55:
45 # - added support for new qr// construct
46 # - added support for new pp_regcreset OP
47 # Changes between 0.55 and 0.56:
48 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
49 # - fixed $# on non-lexicals broken in last big rewrite
50 # - added temporary fix for change in opcode of OP_STRINGIFY
51 # - fixed problem in 0.54's for() patch in `for (@ary)'
52 # - fixed precedence in conditional of ?:
53 # - tweaked list paren elimination in `my($x) = @_'
54 # - made continue-block detection trickier wrt. null ops
55 # - fixed various prototype problems in pp_entersub
56 # - added support for sub prototypes that never get GVs
57 # - added unquoting for special filehandle first arg in truncate
58 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
59 # - added semicolons at the ends of blocks
60 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
61 # Changes between 0.56 and 0.561:
62 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
63 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
64 # Changes between 0.561 and 0.57:
65 # - stylistic changes to symbolic constant stuff
66 # - handled scope in s///e replacement code
67 # - added unquote option for expanding "" into concats, etc.
68 # - split method and proto parts of pp_entersub into separate functions
69 # - various minor cleanups
71 # - added parens in \&foo (patch by Albert Dvornik)
72 # Changes between 0.57 and 0.58:
73 # - fixed `0' statements that weren't being printed
74 # - added methods for use from other programs
75 # (based on patches from James Duncan and Hugo van der Sanden)
76 # - added -si and -sT to control indenting (also based on a patch from Hugo)
77 # - added -sv to print something else instead of '???'
78 # - preliminary version of utf8 tr/// handling
80 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
81 # - added support for Hugo's new OP_SETSTATE (like nextstate)
82 # Changes between 0.58 and 0.59
83 # - added support for Chip's OP_METHOD_NAMED
84 # - added support for Ilya's OPpTARGET_MY optimization
85 # - elided arrows before `()' subscripts when possible
88 # - finish tr/// changes
89 # - add option for even more parens (generalize \&foo change)
90 # - {} around variables in strings ("${var}letters")
93 # - left/right context
94 # - recognize `use utf8', `use integer', etc
95 # - treat top-level block specially for incremental output
96 # - interpret in high bit chars in string as utf8 \x{...} (when?)
97 # - copy comments (look at real text with $^P?)
98 # - avoid semis in one-statement blocks
99 # - associativity of &&=, ||=, ?:
100 # - ',' => '=>' (auto-unquote?)
101 # - break long lines ("\r" as discretionary break?)
102 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
103 # - more style options: brace style, hex vs. octal, quotes, ...
104 # - print big ints as hex/octal instead of decimal (heuristic?)
105 # - handle `my $x if 0'?
106 # - include values of variables (e.g. set in BEGIN)
107 # - coordinate with Data::Dumper (both directions? see previous)
108 # - version using op_next instead of op_first/sibling?
109 # - avoid string copies (pass arrays, one big join?)
111 # - while{} with one-statement continue => for(; XXX; XXX) {}?
112 # - -uPackage:: descend recursively?
116 # Tests that will always fail:
117 # comp/redef.t -- all (redefinition happens at compile time)
119 # Object fields (were globals):
122 # (local($a), local($b)) and local($a, $b) have the same internal
123 # representation but the short form looks better. We notice we can
124 # use a large-scale local when checking the list, but need to prevent
125 # individual locals too. This hash holds the addresses of OPs that
126 # have already had their local-ness accounted for. The same thing
130 # CV for current sub (or main program) being deparsed
133 # name of the current package for deparsed code
136 # array of [cop_seq, GV, is_format?] for subs and formats we still
140 # as above, but [name, prototype] for subs that never got a GV
142 # subs_done, forms_done:
143 # keys are addresses of GVs for subs and formats we've already
144 # deparsed (or at least put into subs_todo)
149 # cuddle: ` ' or `\n', depending on -sC
154 # A little explanation of how precedence contexts and associativity
157 # deparse() calls each per-op subroutine with an argument $cx (short
158 # for context, but not the same as the cx* in the perl core), which is
159 # a number describing the op's parents in terms of precedence, whether
160 # they're inside an expression or at statement level, etc. (see
161 # chart below). When ops with children call deparse on them, they pass
162 # along their precedence. Fractional values are used to implement
163 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
164 # parentheses hacks. The major disadvantage of this scheme is that
165 # it doesn't know about right sides and left sides, so say if you
166 # assign a listop to a variable, it can't tell it's allowed to leave
167 # the parens off the listop.
170 # 26 [TODO] inside interpolation context ("")
171 # 25 left terms and list operators (leftward)
175 # 21 right ! ~ \ and unary + and -
180 # 16 nonassoc named unary operators
181 # 15 nonassoc < > <= >= lt gt le ge
182 # 14 nonassoc == != <=> eq ne cmp
189 # 7 right = += -= *= etc.
191 # 5 nonassoc list operators (rightward)
195 # 1 statement modifiers
198 # Nonprinting characters with special meaning:
199 # \cS - steal parens (see maybe_parens_unop)
200 # \n - newline and indent
201 # \t - increase indent
202 # \b - decrease indent (`outdent')
203 # \f - flush left (no indent)
204 # \cK - kill following semicolon, if any
208 return class($op) eq "NULL";
213 my($gv, $cv, $is_form) = @_;
215 if (!null($cv->START) and is_state($cv->START)) {
216 $seq = $cv->START->cop_seq;
220 push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
225 my $ent = shift @{$self->{'subs_todo'}};
226 my $name = $self->gv_name($ent->[1]);
228 return "format $name =\n"
229 . $self->deparse_format($ent->[1]->FORM). "\n";
231 return "sub $name " . $self->deparse_sub($ent->[1]->CV);
238 if ($op->flags & OPf_KIDS) {
240 for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
241 walk_tree($kid, $sub);
250 $op = shift if null $op;
251 return if !$op or null $op;
254 if ($op->name eq "gv") {
255 my $gv = $self->gv_or_padgv($op);
256 if ($op->next->name eq "entersub") {
257 return if $self->{'subs_done'}{$$gv}++;
258 return if class($gv->CV) eq "SPECIAL";
259 $self->todo($gv, $gv->CV, 0);
260 $self->walk_sub($gv->CV);
261 } elsif ($op->next->name eq "enterwrite"
262 or ($op->next->name eq "rv2gv"
263 and $op->next->next->name eq "enterwrite")) {
264 return if $self->{'forms_done'}{$$gv}++;
265 return if class($gv->FORM) eq "SPECIAL";
266 $self->todo($gv, $gv->FORM, 1);
267 $self->walk_sub($gv->FORM);
277 { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
278 if ($pack eq "main") {
281 $pack = $pack . "::";
284 while (($key, $val) = each %stash) {
285 my $class = class($val);
286 if ($class eq "PV") {
288 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
289 } elsif ($class eq "IV") {
291 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
292 } elsif ($class eq "GV") {
293 if (class($val->CV) ne "SPECIAL") {
294 next if $self->{'subs_done'}{$$val}++;
295 $self->todo($val, $val->CV, 0);
296 $self->walk_sub($val->CV);
298 if (class($val->FORM) ne "SPECIAL") {
299 next if $self->{'forms_done'}{$$val}++;
300 $self->todo($val, $val->FORM, 1);
301 $self->walk_sub($val->FORM);
311 foreach $ar (@{$self->{'protos_todo'}}) {
312 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
313 push @ret, "sub " . $ar->[0] . "$proto;\n";
315 delete $self->{'protos_todo'};
323 while (length($opt = substr($opts, 0, 1))) {
325 $self->{'cuddle'} = " ";
326 $opts = substr($opts, 1);
327 } elsif ($opt eq "i") {
328 $opts =~ s/^i(\d+)//;
329 $self->{'indent_size'} = $1;
330 } elsif ($opt eq "T") {
331 $self->{'use_tabs'} = 1;
332 $opts = substr($opts, 1);
333 } elsif ($opt eq "v") {
334 $opts =~ s/^v([^.]*)(.|$)//;
335 $self->{'ex_const'} = $1;
342 my $self = bless {}, $class;
343 $self->{'subs_todo'} = [];
344 $self->{'curstash'} = "main";
345 $self->{'cuddle'} = "\n";
346 $self->{'indent_size'} = 4;
347 $self->{'use_tabs'} = 0;
348 $self->{'ex_const'} = "'???'";
349 while (my $arg = shift @_) {
350 if (substr($arg, 0, 2) eq "-u") {
351 $self->stash_subs(substr($arg, 2));
352 } elsif ($arg eq "-p") {
353 $self->{'parens'} = 1;
354 } elsif ($arg eq "-l") {
355 $self->{'linenums'} = 1;
356 } elsif ($arg eq "-q") {
357 $self->{'unquote'} = 1;
358 } elsif (substr($arg, 0, 2) eq "-s") {
359 $self->style_opts(substr $arg, 2);
368 my $self = B::Deparse->new(@args);
369 $self->stash_subs("main");
370 $self->{'curcv'} = main_cv;
371 $self->walk_sub(main_cv, main_start);
372 print $self->print_protos;
373 @{$self->{'subs_todo'}} =
374 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
375 print $self->indent($self->deparse(main_root, 0)), "\n"
376 unless null main_root;
378 while (scalar(@{$self->{'subs_todo'}})) {
379 push @text, $self->next_todo;
381 print $self->indent(join("", @text)), "\n" if @text;
388 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
389 return $self->indent($self->deparse_sub(svref_2object($sub)));
395 # cluck if class($op) eq "NULL";
396 # return $self->$ {\("pp_" . $op->name)}($op, $cx);
397 my $meth = "pp_" . $op->name;
398 return $self->$meth($op, $cx);
404 my @lines = split(/\n/, $txt);
409 my $cmd = substr($line, 0, 1);
410 if ($cmd eq "\t" or $cmd eq "\b") {
411 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
412 if ($self->{'use_tabs'}) {
413 $leader = "\t" x ($level / 8) . " " x ($level % 8);
415 $leader = " " x $level;
417 $line = substr($line, 1);
419 if (substr($line, 0, 1) eq "\f") {
420 $line = substr($line, 1); # no indent
422 $line = $leader . $line;
426 return join("\n", @lines);
433 if ($cv->FLAGS & SVf_POK) {
434 $proto = "(". $cv->PV . ") ";
436 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
438 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
439 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
440 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
443 local($self->{'curcv'}) = $cv;
444 local($self->{'curstash'}) = $self->{'curstash'};
445 if (not null $cv->ROOT) {
447 return $proto . "{\n\t" .
448 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
450 return $proto . "{}\n";
458 local($self->{'curcv'}) = $form;
459 local($self->{'curstash'}) = $self->{'curstash'};
460 my $op = $form->ROOT;
462 $op = $op->first->first; # skip leavewrite, lineseq
463 while (not null $op) {
464 $op = $op->sibling; # skip nextstate
466 $kid = $op->first->sibling; # skip pushmark
467 push @text, $self->const_sv($kid)->PV;
468 $kid = $kid->sibling;
469 for (; not null $kid; $kid = $kid->sibling) {
470 push @exprs, $self->deparse($kid, 0);
472 push @text, join(", ", @exprs)."\n" if @exprs;
475 return join("", @text) . ".";
480 return $op->name eq "leave" || $op->name eq "scope"
481 || $op->name eq "lineseq"
482 || ($op->name eq "null" && class($op) eq "UNOP"
483 && (is_scope($op->first) || $op->first->name eq "enter"));
487 my $name = $_[0]->name;
488 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
491 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
493 return (!null($op) and null($op->sibling)
494 and $op->name eq "null" and class($op) eq "UNOP"
495 and (($op->first->name =~ /^(and|or)$/
496 and $op->first->first->sibling->name eq "lineseq")
497 or ($op->first->name eq "lineseq"
498 and not null $op->first->first->sibling
499 and $op->first->first->sibling->name eq "unstack")
505 return ($op->name eq "rv2sv" or
506 $op->name eq "padsv" or
507 $op->name eq "gv" or # only in array/hash constructs
508 $op->flags & OPf_KIDS && !null($op->first)
509 && $op->first->name eq "gvsv");
514 my($text, $cx, $prec) = @_;
515 if ($prec < $cx # unary ops nest just fine
516 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
517 or $self->{'parens'})
520 # In a unop, let parent reuse our parens; see maybe_parens_unop
521 $text = "\cS" . $text if $cx == 16;
528 # same as above, but get around the `if it looks like a function' rule
529 sub maybe_parens_unop {
531 my($name, $kid, $cx) = @_;
532 if ($cx > 16 or $self->{'parens'}) {
533 return "$name(" . $self->deparse($kid, 1) . ")";
535 $kid = $self->deparse($kid, 16);
536 if (substr($kid, 0, 1) eq "\cS") {
538 return $name . substr($kid, 1);
539 } elsif (substr($kid, 0, 1) eq "(") {
540 # avoid looks-like-a-function trap with extra parens
541 # (`+' can lead to ambiguities)
542 return "$name(" . $kid . ")";
549 sub maybe_parens_func {
551 my($func, $text, $cx, $prec) = @_;
552 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
553 return "$func($text)";
555 return "$func $text";
561 my($op, $cx, $text) = @_;
562 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
563 return $self->maybe_parens_func("local", $text, $cx, 16);
571 my($op, $cx, $func, @args) = @_;
572 if ($op->private & OPpTARGET_MY) {
573 my $var = $self->padname($op->targ);
574 my $val = $func->($self, $op, 7, @args);
575 return $self->maybe_parens("$var = $val", $cx, 7);
577 return $func->($self, $op, $cx, @args);
584 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
589 my($op, $cx, $text) = @_;
590 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
591 return $self->maybe_parens_func("my", $text, $cx, 16);
597 # The following OPs don't have functions:
599 # pp_padany -- does not exist after parsing
600 # pp_rcatline -- does not exist
602 sub pp_enter { # see also leave
603 cluck "unexpected OP_ENTER";
607 sub pp_pushmark { # see also list
608 cluck "unexpected OP_PUSHMARK";
612 sub pp_leavesub { # see also deparse_sub
613 cluck "unexpected OP_LEAVESUB";
617 sub pp_leavewrite { # see also deparse_format
618 cluck "unexpected OP_LEAVEWRITE";
622 sub pp_method { # see also entersub
623 cluck "unexpected OP_METHOD";
627 sub pp_regcmaybe { # see also regcomp
628 cluck "unexpected OP_REGCMAYBE";
632 sub pp_regcreset { # see also regcomp
633 cluck "unexpected OP_REGCRESET";
637 sub pp_substcont { # see also subst
638 cluck "unexpected OP_SUBSTCONT";
642 sub pp_grepstart { # see also grepwhile
643 cluck "unexpected OP_GREPSTART";
647 sub pp_mapstart { # see also mapwhile
648 cluck "unexpected OP_MAPSTART";
652 sub pp_flip { # see also flop
653 cluck "unexpected OP_FLIP";
657 sub pp_iter { # see also leaveloop
658 cluck "unexpected OP_ITER";
662 sub pp_enteriter { # see also leaveloop
663 cluck "unexpected OP_ENTERITER";
667 sub pp_enterloop { # see also leaveloop
668 cluck "unexpected OP_ENTERLOOP";
672 sub pp_leaveeval { # see also entereval
673 cluck "unexpected OP_LEAVEEVAL";
677 sub pp_entertry { # see also leavetry
678 cluck "unexpected OP_ENTERTRY";
682 # leave and scope/lineseq should probably share code
688 local($self->{'curstash'}) = $self->{'curstash'};
689 $kid = $op->first->sibling; # skip enter
690 if (is_miniwhile($kid)) {
691 my $top = $kid->first;
692 my $name = $top->name;
693 if ($name eq "and") {
695 } elsif ($name eq "or") {
697 } else { # no conditional -> while 1 or until 0
698 return $self->deparse($top->first, 1) . " while 1";
700 my $cond = $top->first;
701 my $body = $cond->sibling->first; # skip lineseq
702 $cond = $self->deparse($cond, 1);
703 $body = $self->deparse($body, 1);
704 return "$body $name $cond";
706 for (; !null($kid); $kid = $kid->sibling) {
709 $expr = $self->deparse($kid, 0);
710 $kid = $kid->sibling;
713 $expr .= $self->deparse($kid, 0);
714 push @exprs, $expr if length $expr;
716 if ($cx > 0) { # inside an expression
717 return "do { " . join(";\n", @exprs) . " }";
719 return join(";\n", @exprs) . ";";
728 for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
731 $expr = $self->deparse($kid, 0);
732 $kid = $kid->sibling;
735 $expr .= $self->deparse($kid, 0);
736 push @exprs, $expr if length $expr;
738 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
739 return "do { " . join(";\n", @exprs) . " }";
741 return join(";\n", @exprs) . ";";
745 sub pp_lineseq { pp_scope(@_) }
747 # The BEGIN {} is used here because otherwise this code isn't executed
748 # when you run B::Deparse on itself.
750 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
751 "ENV", "ARGV", "ARGVOUT", "_"); }
756 my $stash = $gv->STASH->NAME;
757 my $name = $gv->NAME;
758 if ($stash eq $self->{'curstash'} or $globalnames{$name}
759 or $name =~ /^[^A-Za-z_]/)
763 $stash = $stash . "::";
765 if ($name =~ /^([\cA-\cZ])$/) {
766 $name = "^" . chr(64 + ord($1));
768 return $stash . $name;
771 # Notice how subs and formats are inserted between statements here
776 @text = $op->label . ": " if $op->label;
777 my $seq = $op->cop_seq;
778 while (scalar(@{$self->{'subs_todo'}})
779 and $seq > $self->{'subs_todo'}[0][0]) {
780 push @text, $self->next_todo;
782 my $stash = $op->stashpv;
783 if ($stash ne $self->{'curstash'}) {
784 push @text, "package $stash;\n";
785 $self->{'curstash'} = $stash;
787 if ($self->{'linenums'}) {
788 push @text, "\f#line " . $op->line .
789 ' "' . $op->file, qq'"\n';
791 return join("", @text);
794 sub pp_dbstate { pp_nextstate(@_) }
795 sub pp_setstate { pp_nextstate(@_) }
797 sub pp_unstack { return "" } # see also leaveloop
801 my($op, $cx, $name) = @_;
805 sub pp_stub { baseop(@_, "()") }
806 sub pp_wantarray { baseop(@_, "wantarray") }
807 sub pp_fork { baseop(@_, "fork") }
808 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
809 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
810 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
811 sub pp_tms { baseop(@_, "times") }
812 sub pp_ghostent { baseop(@_, "gethostent") }
813 sub pp_gnetent { baseop(@_, "getnetent") }
814 sub pp_gprotoent { baseop(@_, "getprotoent") }
815 sub pp_gservent { baseop(@_, "getservent") }
816 sub pp_ehostent { baseop(@_, "endhostent") }
817 sub pp_enetent { baseop(@_, "endnetent") }
818 sub pp_eprotoent { baseop(@_, "endprotoent") }
819 sub pp_eservent { baseop(@_, "endservent") }
820 sub pp_gpwent { baseop(@_, "getpwent") }
821 sub pp_spwent { baseop(@_, "setpwent") }
822 sub pp_epwent { baseop(@_, "endpwent") }
823 sub pp_ggrent { baseop(@_, "getgrent") }
824 sub pp_sgrent { baseop(@_, "setgrent") }
825 sub pp_egrent { baseop(@_, "endgrent") }
826 sub pp_getlogin { baseop(@_, "getlogin") }
830 # I couldn't think of a good short name, but this is the category of
831 # symbolic unary operators with interesting precedence
835 my($op, $cx, $name, $prec, $flags) = (@_, 0);
836 my $kid = $op->first;
837 $kid = $self->deparse($kid, $prec);
838 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
842 sub pp_preinc { pfixop(@_, "++", 23) }
843 sub pp_predec { pfixop(@_, "--", 23) }
844 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
845 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
846 sub pp_i_preinc { pfixop(@_, "++", 23) }
847 sub pp_i_predec { pfixop(@_, "--", 23) }
848 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
849 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
850 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
852 sub pp_negate { maybe_targmy(@_, \&real_negate) }
856 if ($op->first->name =~ /^(i_)?negate$/) {
858 $self->pfixop($op, $cx, "-", 21.5);
860 $self->pfixop($op, $cx, "-", 21);
863 sub pp_i_negate { pp_negate(@_) }
869 $self->pfixop($op, $cx, "not ", 4);
871 $self->pfixop($op, $cx, "!", 21);
877 my($op, $cx, $name) = @_;
879 if ($op->flags & OPf_KIDS) {
881 return $self->maybe_parens_unop($name, $kid, $cx);
883 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
887 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
888 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
889 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
890 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
891 sub pp_defined { unop(@_, "defined") }
892 sub pp_undef { unop(@_, "undef") }
893 sub pp_study { unop(@_, "study") }
894 sub pp_ref { unop(@_, "ref") }
895 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
897 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
898 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
899 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
900 sub pp_srand { unop(@_, "srand") }
901 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
902 sub pp_log { maybe_targmy(@_, \&unop, "log") }
903 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
904 sub pp_int { maybe_targmy(@_, \&unop, "int") }
905 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
906 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
907 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
909 sub pp_length { maybe_targmy(@_, \&unop, "length") }
910 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
911 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
913 sub pp_each { unop(@_, "each") }
914 sub pp_values { unop(@_, "values") }
915 sub pp_keys { unop(@_, "keys") }
916 sub pp_pop { unop(@_, "pop") }
917 sub pp_shift { unop(@_, "shift") }
919 sub pp_caller { unop(@_, "caller") }
920 sub pp_reset { unop(@_, "reset") }
921 sub pp_exit { unop(@_, "exit") }
922 sub pp_prototype { unop(@_, "prototype") }
924 sub pp_close { unop(@_, "close") }
925 sub pp_fileno { unop(@_, "fileno") }
926 sub pp_umask { unop(@_, "umask") }
927 sub pp_binmode { unop(@_, "binmode") }
928 sub pp_untie { unop(@_, "untie") }
929 sub pp_tied { unop(@_, "tied") }
930 sub pp_dbmclose { unop(@_, "dbmclose") }
931 sub pp_getc { unop(@_, "getc") }
932 sub pp_eof { unop(@_, "eof") }
933 sub pp_tell { unop(@_, "tell") }
934 sub pp_getsockname { unop(@_, "getsockname") }
935 sub pp_getpeername { unop(@_, "getpeername") }
937 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
938 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
939 sub pp_readlink { unop(@_, "readlink") }
940 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
941 sub pp_readdir { unop(@_, "readdir") }
942 sub pp_telldir { unop(@_, "telldir") }
943 sub pp_rewinddir { unop(@_, "rewinddir") }
944 sub pp_closedir { unop(@_, "closedir") }
945 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
946 sub pp_localtime { unop(@_, "localtime") }
947 sub pp_gmtime { unop(@_, "gmtime") }
948 sub pp_alarm { unop(@_, "alarm") }
949 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
951 sub pp_dofile { unop(@_, "do") }
952 sub pp_entereval { unop(@_, "eval") }
954 sub pp_ghbyname { unop(@_, "gethostbyname") }
955 sub pp_gnbyname { unop(@_, "getnetbyname") }
956 sub pp_gpbyname { unop(@_, "getprotobyname") }
957 sub pp_shostent { unop(@_, "sethostent") }
958 sub pp_snetent { unop(@_, "setnetent") }
959 sub pp_sprotoent { unop(@_, "setprotoent") }
960 sub pp_sservent { unop(@_, "setservent") }
961 sub pp_gpwnam { unop(@_, "getpwnam") }
962 sub pp_gpwuid { unop(@_, "getpwuid") }
963 sub pp_ggrnam { unop(@_, "getgrnam") }
964 sub pp_ggrgid { unop(@_, "getgrgid") }
966 sub pp_lock { unop(@_, "lock") }
971 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
979 if ($op->private & OPpSLICE) {
980 return $self->maybe_parens_func("delete",
981 $self->pp_hslice($op->first, 16),
984 return $self->maybe_parens_func("delete",
985 $self->pp_helem($op->first, 16),
993 if (class($op) eq "UNOP" and $op->first->name eq "const"
994 and $op->first->private & OPpCONST_BARE)
996 my $name = $self->const_sv($op->first)->PV;
999 return "require($name)";
1001 $self->unop($op, $cx, "require");
1008 my $kid = $op->first;
1009 if (not null $kid->sibling) {
1010 # XXX Was a here-doc
1011 return $self->dquote($op);
1013 $self->unop(@_, "scalar");
1020 #cluck "curcv was undef" unless $self->{curcv};
1021 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1027 my $kid = $op->first;
1028 if ($kid->name eq "null") {
1030 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1031 my($pre, $post) = @{{"anonlist" => ["[","]"],
1032 "anonhash" => ["{","}"]}->{$kid->name}};
1034 $kid = $kid->first->sibling; # skip pushmark
1035 for (; !null($kid); $kid = $kid->sibling) {
1036 $expr = $self->deparse($kid, 6);
1039 return $pre . join(", ", @exprs) . $post;
1040 } elsif (!null($kid->sibling) and
1041 $kid->sibling->name eq "anoncode") {
1043 $self->deparse_sub($self->padval($kid->sibling->targ));
1044 } elsif ($kid->name eq "pushmark") {
1045 my $sib_name = $kid->sibling->name;
1046 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1047 and not $kid->sibling->flags & OPf_REF)
1049 # The @a in \(@a) isn't in ref context, but only when the
1051 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1052 } elsif ($sib_name eq 'entersub') {
1053 my $text = $self->deparse($kid->sibling, 1);
1054 # Always show parens for \(&func()), but only with -p otherwise
1055 $text = "($text)" if $self->{'parens'}
1056 or $kid->sibling->private & OPpENTERSUB_AMPER;
1061 $self->pfixop($op, $cx, "\\", 20);
1064 sub pp_srefgen { pp_refgen(@_) }
1069 my $kid = $op->first;
1070 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1071 return "<" . $self->deparse($kid, 1) . ">";
1074 # Unary operators that can occur as pseudo-listops inside double quotes
1077 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1079 if ($op->flags & OPf_KIDS) {
1081 # If there's more than one kid, the first is an ex-pushmark.
1082 $kid = $kid->sibling if not null $kid->sibling;
1083 return $self->maybe_parens_unop($name, $kid, $cx);
1085 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1089 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1090 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1091 sub pp_uc { dq_unop(@_, "uc") }
1092 sub pp_lc { dq_unop(@_, "lc") }
1093 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1097 my ($op, $cx, $name) = @_;
1098 if (class($op) eq "PVOP") {
1099 return "$name " . $op->pv;
1100 } elsif (class($op) eq "OP") {
1102 } elsif (class($op) eq "UNOP") {
1103 # Note -- loop exits are actually exempt from the
1104 # looks-like-a-func rule, but a few extra parens won't hurt
1105 return $self->maybe_parens_unop($name, $op->first, $cx);
1109 sub pp_last { loopex(@_, "last") }
1110 sub pp_next { loopex(@_, "next") }
1111 sub pp_redo { loopex(@_, "redo") }
1112 sub pp_goto { loopex(@_, "goto") }
1113 sub pp_dump { loopex(@_, "dump") }
1117 my($op, $cx, $name) = @_;
1118 if (class($op) eq "UNOP") {
1119 # Genuine `-X' filetests are exempt from the LLAFR, but not
1120 # l?stat(); for the sake of clarity, give'em all parens
1121 return $self->maybe_parens_unop($name, $op->first, $cx);
1122 } elsif (class($op) eq "SVOP") {
1123 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1124 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1129 sub pp_lstat { ftst(@_, "lstat") }
1130 sub pp_stat { ftst(@_, "stat") }
1131 sub pp_ftrread { ftst(@_, "-R") }
1132 sub pp_ftrwrite { ftst(@_, "-W") }
1133 sub pp_ftrexec { ftst(@_, "-X") }
1134 sub pp_fteread { ftst(@_, "-r") }
1135 sub pp_ftewrite { ftst(@_, "-r") }
1136 sub pp_fteexec { ftst(@_, "-r") }
1137 sub pp_ftis { ftst(@_, "-e") }
1138 sub pp_fteowned { ftst(@_, "-O") }
1139 sub pp_ftrowned { ftst(@_, "-o") }
1140 sub pp_ftzero { ftst(@_, "-z") }
1141 sub pp_ftsize { ftst(@_, "-s") }
1142 sub pp_ftmtime { ftst(@_, "-M") }
1143 sub pp_ftatime { ftst(@_, "-A") }
1144 sub pp_ftctime { ftst(@_, "-C") }
1145 sub pp_ftsock { ftst(@_, "-S") }
1146 sub pp_ftchr { ftst(@_, "-c") }
1147 sub pp_ftblk { ftst(@_, "-b") }
1148 sub pp_ftfile { ftst(@_, "-f") }
1149 sub pp_ftdir { ftst(@_, "-d") }
1150 sub pp_ftpipe { ftst(@_, "-p") }
1151 sub pp_ftlink { ftst(@_, "-l") }
1152 sub pp_ftsuid { ftst(@_, "-u") }
1153 sub pp_ftsgid { ftst(@_, "-g") }
1154 sub pp_ftsvtx { ftst(@_, "-k") }
1155 sub pp_fttty { ftst(@_, "-t") }
1156 sub pp_fttext { ftst(@_, "-T") }
1157 sub pp_ftbinary { ftst(@_, "-B") }
1159 sub SWAP_CHILDREN () { 1 }
1160 sub ASSIGN () { 2 } # has OP= variant
1166 my $name = $op->name;
1167 if ($name eq "concat" and $op->first->name eq "concat") {
1168 # avoid spurious `=' -- see comment in pp_concat
1171 if ($name eq "null" and class($op) eq "UNOP"
1172 and $op->first->name =~ /^(and|x?or)$/
1173 and null $op->first->sibling)
1175 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1176 # with a null that's used as the common end point of the two
1177 # flows of control. For precedence purposes, ignore it.
1178 # (COND_EXPRs have these too, but we don't bother with
1179 # their associativity).
1180 return assoc_class($op->first);
1182 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1185 # Left associative operators, like `+', for which
1186 # $a + $b + $c is equivalent to ($a + $b) + $c
1189 %left = ('multiply' => 19, 'i_multiply' => 19,
1190 'divide' => 19, 'i_divide' => 19,
1191 'modulo' => 19, 'i_modulo' => 19,
1193 'add' => 18, 'i_add' => 18,
1194 'subtract' => 18, 'i_subtract' => 18,
1196 'left_shift' => 17, 'right_shift' => 17,
1198 'bit_or' => 12, 'bit_xor' => 12,
1200 'or' => 2, 'xor' => 2,
1204 sub deparse_binop_left {
1206 my($op, $left, $prec) = @_;
1207 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1208 and $left{assoc_class($op)} == $left{assoc_class($left)})
1210 return $self->deparse($left, $prec - .00001);
1212 return $self->deparse($left, $prec);
1216 # Right associative operators, like `=', for which
1217 # $a = $b = $c is equivalent to $a = ($b = $c)
1220 %right = ('pow' => 22,
1221 'sassign=' => 7, 'aassign=' => 7,
1222 'multiply=' => 7, 'i_multiply=' => 7,
1223 'divide=' => 7, 'i_divide=' => 7,
1224 'modulo=' => 7, 'i_modulo=' => 7,
1226 'add=' => 7, 'i_add=' => 7,
1227 'subtract=' => 7, 'i_subtract=' => 7,
1229 'left_shift=' => 7, 'right_shift=' => 7,
1231 'bit_or=' => 7, 'bit_xor=' => 7,
1237 sub deparse_binop_right {
1239 my($op, $right, $prec) = @_;
1240 if ($right{assoc_class($op)} && $right{assoc_class($right)}
1241 and $right{assoc_class($op)} == $right{assoc_class($right)})
1243 return $self->deparse($right, $prec - .00001);
1245 return $self->deparse($right, $prec);
1251 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1252 my $left = $op->first;
1253 my $right = $op->last;
1255 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1259 if ($flags & SWAP_CHILDREN) {
1260 ($left, $right) = ($right, $left);
1262 $left = $self->deparse_binop_left($op, $left, $prec);
1263 $right = $self->deparse_binop_right($op, $right, $prec);
1264 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1267 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1268 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1269 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1270 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1271 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1272 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1273 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1274 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1275 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1276 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1277 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1279 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1280 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1281 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1282 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1283 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1285 sub pp_eq { binop(@_, "==", 14) }
1286 sub pp_ne { binop(@_, "!=", 14) }
1287 sub pp_lt { binop(@_, "<", 15) }
1288 sub pp_gt { binop(@_, ">", 15) }
1289 sub pp_ge { binop(@_, ">=", 15) }
1290 sub pp_le { binop(@_, "<=", 15) }
1291 sub pp_ncmp { binop(@_, "<=>", 14) }
1292 sub pp_i_eq { binop(@_, "==", 14) }
1293 sub pp_i_ne { binop(@_, "!=", 14) }
1294 sub pp_i_lt { binop(@_, "<", 15) }
1295 sub pp_i_gt { binop(@_, ">", 15) }
1296 sub pp_i_ge { binop(@_, ">=", 15) }
1297 sub pp_i_le { binop(@_, "<=", 15) }
1298 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1300 sub pp_seq { binop(@_, "eq", 14) }
1301 sub pp_sne { binop(@_, "ne", 14) }
1302 sub pp_slt { binop(@_, "lt", 15) }
1303 sub pp_sgt { binop(@_, "gt", 15) }
1304 sub pp_sge { binop(@_, "ge", 15) }
1305 sub pp_sle { binop(@_, "le", 15) }
1306 sub pp_scmp { binop(@_, "cmp", 14) }
1308 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1309 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1311 # `.' is special because concats-of-concats are optimized to save copying
1312 # by making all but the first concat stacked. The effect is as if the
1313 # programmer had written `($a . $b) .= $c', except legal.
1314 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1318 my $left = $op->first;
1319 my $right = $op->last;
1322 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1326 $left = $self->deparse_binop_left($op, $left, $prec);
1327 $right = $self->deparse_binop_right($op, $right, $prec);
1328 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1331 # `x' is weird when the left arg is a list
1335 my $left = $op->first;
1336 my $right = $op->last;
1339 if ($op->flags & OPf_STACKED) {
1343 if (null($right)) { # list repeat; count is inside left-side ex-list
1344 my $kid = $left->first->sibling; # skip pushmark
1346 for (; !null($kid->sibling); $kid = $kid->sibling) {
1347 push @exprs, $self->deparse($kid, 6);
1350 $left = "(" . join(", ", @exprs). ")";
1352 $left = $self->deparse_binop_left($op, $left, $prec);
1354 $right = $self->deparse_binop_right($op, $right, $prec);
1355 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1360 my ($op, $cx, $type) = @_;
1361 my $left = $op->first;
1362 my $right = $left->sibling;
1363 $left = $self->deparse($left, 9);
1364 $right = $self->deparse($right, 9);
1365 return $self->maybe_parens("$left $type $right", $cx, 9);
1371 my $flip = $op->first;
1372 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1373 return $self->range($flip->first, $cx, $type);
1376 # one-line while/until is handled in pp_leave
1380 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1381 my $left = $op->first;
1382 my $right = $op->first->sibling;
1383 if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
1384 $left = $self->deparse($left, 1);
1385 $right = $self->deparse($right, 0);
1386 return "$blockname ($left) {\n\t$right\n\b}\cK";
1387 } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
1388 $right = $self->deparse($right, 1);
1389 $left = $self->deparse($left, 1);
1390 return "$right $blockname $left";
1391 } elsif ($cx > $lowprec and $highop) { # $a && $b
1392 $left = $self->deparse_binop_left($op, $left, $highprec);
1393 $right = $self->deparse_binop_right($op, $right, $highprec);
1394 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1395 } else { # $a and $b
1396 $left = $self->deparse_binop_left($op, $left, $lowprec);
1397 $right = $self->deparse_binop_right($op, $right, $lowprec);
1398 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1402 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1403 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1405 # xor is syntactically a logop, but it's really a binop (contrary to
1406 # old versions of opcode.pl). Syntax is what matters here.
1407 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1411 my ($op, $cx, $opname) = @_;
1412 my $left = $op->first;
1413 my $right = $op->first->sibling->first; # skip sassign
1414 $left = $self->deparse($left, 7);
1415 $right = $self->deparse($right, 7);
1416 return $self->maybe_parens("$left $opname $right", $cx, 7);
1419 sub pp_andassign { logassignop(@_, "&&=") }
1420 sub pp_orassign { logassignop(@_, "||=") }
1424 my($op, $cx, $name) = @_;
1426 my $parens = ($cx >= 5) || $self->{'parens'};
1427 my $kid = $op->first->sibling;
1428 return $name if null $kid;
1429 my $first = $self->deparse($kid, 6);
1430 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1431 push @exprs, $first;
1432 $kid = $kid->sibling;
1433 for (; !null($kid); $kid = $kid->sibling) {
1434 push @exprs, $self->deparse($kid, 6);
1437 return "$name(" . join(", ", @exprs) . ")";
1439 return "$name " . join(", ", @exprs);
1443 sub pp_bless { listop(@_, "bless") }
1444 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
1445 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1446 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1447 sub pp_index { maybe_targmy(@_, \&listop, "index") }
1448 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
1449 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
1450 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1451 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
1452 sub pp_unpack { listop(@_, "unpack") }
1453 sub pp_pack { listop(@_, "pack") }
1454 sub pp_join { maybe_targmy(@_, \&listop, "join") }
1455 sub pp_splice { listop(@_, "splice") }
1456 sub pp_push { maybe_targmy(@_, \&listop, "push") }
1457 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
1458 sub pp_reverse { listop(@_, "reverse") }
1459 sub pp_warn { listop(@_, "warn") }
1460 sub pp_die { listop(@_, "die") }
1461 # Actually, return is exempt from the LLAFR (see examples in this very
1462 # module!), but for consistency's sake, ignore that fact
1463 sub pp_return { listop(@_, "return") }
1464 sub pp_open { listop(@_, "open") }
1465 sub pp_pipe_op { listop(@_, "pipe") }
1466 sub pp_tie { listop(@_, "tie") }
1467 sub pp_dbmopen { listop(@_, "dbmopen") }
1468 sub pp_sselect { listop(@_, "select") }
1469 sub pp_select { listop(@_, "select") }
1470 sub pp_read { listop(@_, "read") }
1471 sub pp_sysopen { listop(@_, "sysopen") }
1472 sub pp_sysseek { listop(@_, "sysseek") }
1473 sub pp_sysread { listop(@_, "sysread") }
1474 sub pp_syswrite { listop(@_, "syswrite") }
1475 sub pp_send { listop(@_, "send") }
1476 sub pp_recv { listop(@_, "recv") }
1477 sub pp_seek { listop(@_, "seek") }
1478 sub pp_fcntl { listop(@_, "fcntl") }
1479 sub pp_ioctl { listop(@_, "ioctl") }
1480 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
1481 sub pp_socket { listop(@_, "socket") }
1482 sub pp_sockpair { listop(@_, "sockpair") }
1483 sub pp_bind { listop(@_, "bind") }
1484 sub pp_connect { listop(@_, "connect") }
1485 sub pp_listen { listop(@_, "listen") }
1486 sub pp_accept { listop(@_, "accept") }
1487 sub pp_shutdown { listop(@_, "shutdown") }
1488 sub pp_gsockopt { listop(@_, "getsockopt") }
1489 sub pp_ssockopt { listop(@_, "setsockopt") }
1490 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
1491 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
1492 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
1493 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
1494 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
1495 sub pp_link { maybe_targmy(@_, \&listop, "link") }
1496 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
1497 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
1498 sub pp_open_dir { listop(@_, "opendir") }
1499 sub pp_seekdir { listop(@_, "seekdir") }
1500 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
1501 sub pp_system { maybe_targmy(@_, \&listop, "system") }
1502 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
1503 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
1504 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
1505 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
1506 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
1507 sub pp_shmget { listop(@_, "shmget") }
1508 sub pp_shmctl { listop(@_, "shmctl") }
1509 sub pp_shmread { listop(@_, "shmread") }
1510 sub pp_shmwrite { listop(@_, "shmwrite") }
1511 sub pp_msgget { listop(@_, "msgget") }
1512 sub pp_msgctl { listop(@_, "msgctl") }
1513 sub pp_msgsnd { listop(@_, "msgsnd") }
1514 sub pp_msgrcv { listop(@_, "msgrcv") }
1515 sub pp_semget { listop(@_, "semget") }
1516 sub pp_semctl { listop(@_, "semctl") }
1517 sub pp_semop { listop(@_, "semop") }
1518 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1519 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1520 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1521 sub pp_gsbyname { listop(@_, "getservbyname") }
1522 sub pp_gsbyport { listop(@_, "getservbyport") }
1523 sub pp_syscall { listop(@_, "syscall") }
1528 my $text = $self->dq($op->first->sibling); # skip pushmark
1529 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1530 or $text =~ /[<>]/) {
1531 return 'glob(' . single_delim('qq', '"', $text) . ')';
1533 return '<' . $text . '>';
1537 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1538 # be a filehandle. This could probably be better fixed in the core
1539 # by moving the GV lookup into ck_truc.
1545 my $parens = ($cx >= 5) || $self->{'parens'};
1546 my $kid = $op->first->sibling;
1548 if ($op->flags & OPf_SPECIAL) {
1549 # $kid is an OP_CONST
1550 $fh = $self->const_sv($kid)->PV;
1552 $fh = $self->deparse($kid, 6);
1553 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1555 my $len = $self->deparse($kid->sibling, 6);
1557 return "truncate($fh, $len)";
1559 return "truncate $fh, $len";
1565 my($op, $cx, $name) = @_;
1567 my $kid = $op->first->sibling;
1569 if ($op->flags & OPf_STACKED) {
1571 $indir = $indir->first; # skip rv2gv
1572 if (is_scope($indir)) {
1573 $indir = "{" . $self->deparse($indir, 0) . "}";
1575 $indir = $self->deparse($indir, 24);
1577 $indir = $indir . " ";
1578 $kid = $kid->sibling;
1580 for (; !null($kid); $kid = $kid->sibling) {
1581 $expr = $self->deparse($kid, 6);
1584 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
1588 sub pp_prtf { indirop(@_, "printf") }
1589 sub pp_print { indirop(@_, "print") }
1590 sub pp_sort { indirop(@_, "sort") }
1594 my($op, $cx, $name) = @_;
1596 my $kid = $op->first; # this is the (map|grep)start
1597 $kid = $kid->first->sibling; # skip a pushmark
1598 my $code = $kid->first; # skip a null
1599 if (is_scope $code) {
1600 $code = "{" . $self->deparse($code, 0) . "} ";
1602 $code = $self->deparse($code, 24) . ", ";
1604 $kid = $kid->sibling;
1605 for (; !null($kid); $kid = $kid->sibling) {
1606 $expr = $self->deparse($kid, 6);
1607 push @exprs, $expr if $expr;
1609 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1612 sub pp_mapwhile { mapop(@_, "map") }
1613 sub pp_grepwhile { mapop(@_, "grep") }
1619 my $kid = $op->first->sibling; # skip pushmark
1621 my $local = "either"; # could be local(...) or my(...)
1622 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1623 # This assumes that no other private flags equal 128, and that
1624 # OPs that store things other than flags in their op_private,
1625 # like OP_AELEMFAST, won't be immediate children of a list.
1626 unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
1628 $local = ""; # or not
1631 if ($lop->name =~ /^pad[ash]v$/) { # my()
1632 ($local = "", last) if $local eq "local";
1634 } elsif ($lop->name ne "undef") { # local()
1635 ($local = "", last) if $local eq "my";
1639 $local = "" if $local eq "either"; # no point if it's all undefs
1640 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
1641 for (; !null($kid); $kid = $kid->sibling) {
1643 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
1648 $self->{'avoid_local'}{$$lop}++;
1649 $expr = $self->deparse($kid, 6);
1650 delete $self->{'avoid_local'}{$$lop};
1652 $expr = $self->deparse($kid, 6);
1657 return "$local(" . join(", ", @exprs) . ")";
1659 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1663 sub is_ifelse_cont {
1665 return ($op->name eq "null" and class($op) eq "UNOP"
1666 and $op->first->name =~ /^(and|cond_expr)$/
1667 and is_scope($op->first->first->sibling));
1673 my $cond = $op->first;
1674 my $true = $cond->sibling;
1675 my $false = $true->sibling;
1676 my $cuddle = $self->{'cuddle'};
1677 unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
1678 (is_scope($false) || is_ifelse_cont($false))) {
1679 $cond = $self->deparse($cond, 8);
1680 $true = $self->deparse($true, 8);
1681 $false = $self->deparse($false, 8);
1682 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1685 $cond = $self->deparse($cond, 1);
1686 $true = $self->deparse($true, 0);
1687 my $head = "if ($cond) {\n\t$true\n\b}";
1689 while (!null($false) and is_ifelse_cont($false)) {
1690 my $newop = $false->first;
1691 my $newcond = $newop->first;
1692 my $newtrue = $newcond->sibling;
1693 $false = $newtrue->sibling; # last in chain is OP_AND => no else
1694 $newcond = $self->deparse($newcond, 1);
1695 $newtrue = $self->deparse($newtrue, 0);
1696 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1698 if (!null($false)) {
1699 $false = $cuddle . "else {\n\t" .
1700 $self->deparse($false, 0) . "\n\b}\cK";
1704 return $head . join($cuddle, "", @elsifs) . $false;
1710 my $enter = $op->first;
1711 my $kid = $enter->sibling;
1712 local($self->{'curstash'}) = $self->{'curstash'};
1715 if ($kid->name eq "lineseq") { # bare or infinite loop
1716 if (is_state $kid->last) { # infinite
1717 $head = "for (;;) "; # shorter than while (1)
1721 } elsif ($enter->name eq "enteriter") { # foreach
1722 my $ary = $enter->first->sibling; # first was pushmark
1723 my $var = $ary->sibling;
1724 if ($enter->flags & OPf_STACKED
1725 and not null $ary->first->sibling->sibling)
1727 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1728 $self->deparse($ary->first->sibling->sibling, 9);
1730 $ary = $self->deparse($ary, 1);
1733 if ($enter->flags & OPf_SPECIAL) { # thread special var
1734 $var = $self->pp_threadsv($enter, 1);
1735 } else { # regular my() variable
1736 $var = $self->pp_padsv($enter, 1);
1737 if ($self->padname_sv($enter->targ)->IVX ==
1738 $kid->first->first->sibling->last->cop_seq)
1740 # If the scope of this variable closes at the last
1741 # statement of the loop, it must have been
1743 $var = "my " . $var;
1746 } elsif ($var->name eq "rv2gv") {
1747 $var = $self->pp_rv2sv($var, 1);
1748 } elsif ($var->name eq "gv") {
1749 $var = "\$" . $self->deparse($var, 1);
1751 $head = "foreach $var ($ary) ";
1752 $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1753 } elsif ($kid->name eq "null") { # while/until
1755 my $name = {"and" => "while", "or" => "until"}
1757 $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
1758 $kid = $kid->first->sibling;
1759 } elsif ($kid->name eq "stub") { # bare and empty
1760 return "{;}"; # {} could be a hashref
1762 # The third-to-last kid is the continue block if the pointer used
1763 # by `next BLOCK' points to its first OP, which happens to be the
1764 # the op_next of the head of the _previous_ statement.
1765 # Unless it's a bare loop, in which case it's last, since there's
1766 # no unstack or extra nextstate.
1767 # Except if the previous head isn't null but the first kid is
1768 # (because it's a nulled out nextstate in a scope), in which
1769 # case the head's next is advanced past the null but the nextop's
1770 # isn't, so we need to try nextop->next.
1772 my $cont = $kid->first;
1774 while (!null($cont->sibling)) {
1776 $cont = $cont->sibling;
1779 while (!null($cont->sibling->sibling->sibling)) {
1781 $cont = $cont->sibling;
1784 if ($precont and $ {$precont->next} == $ {$enter->nextop}
1785 || $ {$precont->next} == $ {$enter->nextop->next} )
1787 my $state = $kid->first;
1788 my $cuddle = $self->{'cuddle'};
1790 for (; $$state != $$cont; $state = $state->sibling) {
1792 if (is_state $state) {
1793 $expr = $self->deparse($state, 0);
1794 $state = $state->sibling;
1795 last if null $state;
1797 $expr .= $self->deparse($state, 0);
1798 push @exprs, $expr if $expr;
1800 $kid = join(";\n", @exprs);
1801 $cont = $cuddle . "continue {\n\t" .
1802 $self->deparse($cont, 0) . "\n\b}\cK";
1805 $kid = $self->deparse($kid, 0);
1807 return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1812 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
1815 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
1816 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
1821 if (class($op) eq "OP") {
1823 return $self->{'ex_const'} if $op->targ == OP_CONST;
1824 } elsif ($op->first->name eq "pushmark") {
1825 return $self->pp_list($op, $cx);
1826 } elsif ($op->first->name eq "enter") {
1827 return $self->pp_leave($op, $cx);
1828 } elsif ($op->targ == OP_STRINGIFY) {
1829 return $self->dquote($op, $cx);
1830 } elsif (!null($op->first->sibling) and
1831 $op->first->sibling->name eq "readline" and
1832 $op->first->sibling->flags & OPf_STACKED) {
1833 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1834 . $self->deparse($op->first->sibling, 7),
1836 } elsif (!null($op->first->sibling) and
1837 $op->first->sibling->name eq "trans" and
1838 $op->first->sibling->flags & OPf_STACKED) {
1839 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1840 . $self->deparse($op->first->sibling, 20),
1843 return $self->deparse($op->first, $cx);
1847 # the aassign in-common check messes up SvCUR (always setting it
1848 # to a value >= 100), but it's probably safe to assume there
1849 # won't be any NULs in the names of my() variables. (with
1850 # stash variables, I wouldn't be so sure)
1853 $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
1860 my $str = $self->padname_sv($targ)->PV;
1861 return padname_fix($str);
1867 return substr($self->padname($op->targ), 1); # skip $/@/%
1873 return $self->maybe_my($op, $cx, $self->padname($op->targ));
1876 sub pp_padav { pp_padsv(@_) }
1877 sub pp_padhv { pp_padsv(@_) }
1882 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1883 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1884 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1891 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
1897 if (class($op) eq "PADOP") {
1898 return $self->padval($op->padix);
1899 } else { # class($op) eq "SVOP"
1907 my $gv = $self->gv_or_padgv($op);
1908 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv));
1914 my $gv = $self->gv_or_padgv($op);
1915 return $self->gv_name($gv);
1921 my $gv = $self->gv_or_padgv($op);
1922 return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1927 my($op, $cx, $type) = @_;
1928 my $kid = $op->first;
1929 my $str = $self->deparse($kid, 0);
1930 return $type . (is_scalar($kid) ? $str : "{$str}");
1933 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1934 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1935 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1941 if ($op->first->name eq "padav") {
1942 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
1944 return $self->maybe_local($op, $cx,
1945 $self->rv2x($op->first, $cx, '$#'));
1949 # skip down to the old, ex-rv2cv
1950 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
1955 my $kid = $op->first;
1956 if ($kid->name eq "const") { # constant list
1957 my $av = $self->const_sv($kid);
1958 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1960 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
1964 sub is_subscriptable {
1966 if ($op->name =~ /^[ahg]elem/) {
1968 } elsif ($op->name eq "entersub") {
1969 my $kid = $op->first;
1970 return 0 unless null $kid->sibling;
1972 $kid = $kid->sibling until null $kid->sibling;
1973 return 0 if is_scope($kid);
1975 return 0 if $kid->name eq "gv";
1976 return 0 if is_scalar($kid);
1977 return is_subscriptable($kid);
1985 my ($op, $cx, $left, $right, $padname) = @_;
1986 my($array, $idx) = ($op->first, $op->first->sibling);
1987 unless ($array->name eq $padname) { # Maybe this has been fixed
1988 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1990 if ($array->name eq $padname) {
1991 $array = $self->padany($array);
1992 } elsif (is_scope($array)) { # ${expr}[0]
1993 $array = "{" . $self->deparse($array, 0) . "}";
1994 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
1995 $array = $self->deparse($array, 24);
1997 # $x[20][3]{hi} or expr->[20]
1998 my $arrow = is_subscriptable($array) ? "" : "->";
1999 return $self->deparse($array, 24) . $arrow .
2000 $left . $self->deparse($idx, 1) . $right;
2002 $idx = $self->deparse($idx, 1);
2003 return "\$" . $array . $left . $idx . $right;
2006 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2007 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2012 my($glob, $part) = ($op->first, $op->last);
2013 $glob = $glob->first; # skip rv2gv
2014 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2015 my $scope = is_scope($glob);
2016 $glob = $self->deparse($glob, 0);
2017 $part = $self->deparse($part, 1);
2018 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2023 my ($op, $cx, $left, $right, $regname, $padname) = @_;
2025 my(@elems, $kid, $array, $list);
2026 if (class($op) eq "LISTOP") {
2028 } else { # ex-hslice inside delete()
2029 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2033 $array = $array->first
2034 if $array->name eq $regname or $array->name eq "null";
2035 if (is_scope($array)) {
2036 $array = "{" . $self->deparse($array, 0) . "}";
2037 } elsif ($array->name eq $padname) {
2038 $array = $self->padany($array);
2040 $array = $self->deparse($array, 24);
2042 $kid = $op->first->sibling; # skip pushmark
2043 if ($kid->name eq "list") {
2044 $kid = $kid->first->sibling; # skip list, pushmark
2045 for (; !null $kid; $kid = $kid->sibling) {
2046 push @elems, $self->deparse($kid, 6);
2048 $list = join(", ", @elems);
2050 $list = $self->deparse($kid, 1);
2052 return "\@" . $array . $left . $list . $right;
2055 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2056 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2061 my $idx = $op->first;
2062 my $list = $op->last;
2064 $list = $self->deparse($list, 1);
2065 $idx = $self->deparse($idx, 1);
2066 return "($list)" . "[$idx]";
2071 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2076 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2082 my $kid = $op->first->sibling; # skip pushmark
2083 my($meth, $obj, @exprs);
2084 if ($kid->name eq "list" and want_list $kid) {
2085 # When an indirect object isn't a bareword but the args are in
2086 # parens, the parens aren't part of the method syntax (the LLAFR
2087 # doesn't apply), but they make a list with OPf_PARENS set that
2088 # doesn't get flattened by the append_elem that adds the method,
2089 # making a (object, arg1, arg2, ...) list where the object
2090 # usually is. This can be distinguished from
2091 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2092 # object) because in the later the list is in scalar context
2093 # as the left side of -> always is, while in the former
2094 # the list is in list context as method arguments always are.
2095 # (Good thing there aren't method prototypes!)
2096 $meth = $kid->sibling;
2097 $kid = $kid->first->sibling; # skip pushmark
2099 $kid = $kid->sibling;
2100 for (; not null $kid; $kid = $kid->sibling) {
2101 push @exprs, $self->deparse($kid, 6);
2105 $kid = $kid->sibling;
2106 for (; not null $kid->sibling; $kid = $kid->sibling) {
2107 push @exprs, $self->deparse($kid, 6);
2111 $obj = $self->deparse($obj, 24);
2112 if ($meth->name eq "method_named") {
2113 $meth = $self->const_sv($meth)->PV;
2115 $meth = $meth->first;
2116 if ($meth->name eq "const") {
2117 # As of 5.005_58, this case is probably obsoleted by the
2118 # method_named case above
2119 $meth = $self->const_sv($meth)->PV; # needs to be bare
2121 $meth = $self->deparse($meth, 1);
2124 my $args = join(", ", @exprs);
2125 $kid = $obj . "->" . $meth;
2127 return $kid . "(" . $args . ")"; # parens mandatory
2133 # returns "&" if the prototype doesn't match the args,
2134 # or ("", $args_after_prototype_demunging) if it does.
2137 my($proto, @args) = @_;
2141 # An unbackslashed @ or % gobbles up the rest of the args
2142 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2144 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2147 return "&" if @args;
2148 } elsif ($chr eq ";") {
2150 } elsif ($chr eq "@" or $chr eq "%") {
2151 push @reals, map($self->deparse($_, 6), @args);
2157 if (want_scalar $arg) {
2158 push @reals, $self->deparse($arg, 6);
2162 } elsif ($chr eq "&") {
2163 if ($arg->name =~ /^(s?refgen|undef)$/) {
2164 push @reals, $self->deparse($arg, 6);
2168 } elsif ($chr eq "*") {
2169 if ($arg->name =~ /^s?refgen$/
2170 and $arg->first->first->name eq "rv2gv")
2172 $real = $arg->first->first; # skip refgen, null
2173 if ($real->first->name eq "gv") {
2174 push @reals, $self->deparse($real, 6);
2176 push @reals, $self->deparse($real->first, 6);
2181 } elsif (substr($chr, 0, 1) eq "\\") {
2182 $chr = substr($chr, 1);
2183 if ($arg->name =~ /^s?refgen$/ and
2184 !null($real = $arg->first) and
2185 ($chr eq "\$" && is_scalar($real->first)
2187 && $real->first->sibling->name
2190 && $real->first->sibling->name
2192 #or ($chr eq "&" # This doesn't work
2193 # && $real->first->name eq "rv2cv")
2195 && $real->first->name eq "rv2gv")))
2197 push @reals, $self->deparse($real, 6);
2204 return "&" if $proto and !$doneok; # too few args and no `;'
2205 return "&" if @args; # too many args
2206 return ("", join ", ", @reals);
2212 return $self->method($op, $cx) unless null $op->first->sibling;
2216 if ($op->flags & OPf_SPECIAL) {
2218 } elsif ($op->private & OPpENTERSUB_AMPER) {
2222 $kid = $kid->first->sibling; # skip ex-list, pushmark
2223 for (; not null $kid->sibling; $kid = $kid->sibling) {
2228 if (is_scope($kid)) {
2230 $kid = "{" . $self->deparse($kid, 0) . "}";
2231 } elsif ($kid->first->name eq "gv") {
2232 my $gv = $self->gv_or_padgv($kid->first);
2233 if (class($gv->CV) ne "SPECIAL") {
2234 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2236 $simple = 1; # only calls of named functions can be prototyped
2237 $kid = $self->deparse($kid, 24);
2238 } elsif (is_scalar $kid->first) {
2240 $kid = $self->deparse($kid, 24);
2243 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2244 $kid = $self->deparse($kid, 24) . $arrow;
2247 if (defined $proto and not $amper) {
2248 ($amper, $args) = $self->check_proto($proto, @exprs);
2249 if ($amper eq "&") {
2250 $args = join(", ", map($self->deparse($_, 6), @exprs));
2253 $args = join(", ", map($self->deparse($_, 6), @exprs));
2255 if ($prefix or $amper) {
2256 if ($op->flags & OPf_STACKED) {
2257 return $prefix . $amper . $kid . "(" . $args . ")";
2259 return $prefix . $amper. $kid;
2262 if (defined $proto and $proto eq "") {
2264 } elsif (defined $proto and $proto eq "\$") {
2265 return $self->maybe_parens_func($kid, $args, $cx, 16);
2266 } elsif (defined($proto) && $proto or $simple) {
2267 return $self->maybe_parens_func($kid, $args, $cx, 5);
2269 return "$kid(" . $args . ")";
2274 sub pp_enterwrite { unop(@_, "write") }
2276 # escape things that cause interpolation in double quotes,
2277 # but not character escapes
2280 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2284 # the same, but treat $|, $), and $ at the end of the string differently
2287 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2288 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2292 # character escapes, but not delimiters that might need to be escaped
2293 sub escape_str { # ASCII
2296 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2302 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2303 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2307 # Don't do this for regexen
2310 $str =~ s/\\/\\\\/g;
2314 sub balanced_delim {
2316 my @str = split //, $str;
2317 my($ar, $open, $close, $fail, $c, $cnt);
2318 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2319 ($open, $close) = @$ar;
2320 $fail = 0; $cnt = 0;
2324 } elsif ($c eq $close) {
2333 $fail = 1 if $cnt != 0;
2334 return ($open, "$open$str$close") if not $fail;
2340 my($q, $default, $str) = @_;
2341 return "$default$str$default" if $default and index($str, $default) == -1;
2342 my($succeed, $delim);
2343 ($succeed, $str) = balanced_delim($str);
2344 return "$q$str" if $succeed;
2345 for $delim ('/', '"', '#') {
2346 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2349 $str =~ s/$default/\\$default/g;
2350 return "$default$str$default";
2359 if (class($sv) eq "SPECIAL") {
2360 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2361 } elsif ($sv->FLAGS & SVf_IOK) {
2363 } elsif ($sv->FLAGS & SVf_NOK) {
2365 } elsif ($sv->FLAGS & SVf_ROK) {
2366 return "\\(" . const($sv->RV) . ")"; # constant folded
2369 if ($str =~ /[^ -~]/) { # ASCII for non-printing
2370 return single_delim("qq", '"', uninterp escape_str unback $str);
2372 return single_delim("q", "'", unback $str);
2381 # the constant could be in the pad (under useithreads)
2382 $sv = $self->padval($op->targ) unless $$sv;
2389 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2390 # return $self->const_sv($op)->PV;
2392 my $sv = $self->const_sv($op);
2399 my $type = $op->name;
2400 if ($type eq "const") {
2401 return uninterp(escape_str(unback($self->const_sv($op)->PV)));
2402 } elsif ($type eq "concat") {
2403 return $self->dq($op->first) . $self->dq($op->last);
2404 } elsif ($type eq "uc") {
2405 return '\U' . $self->dq($op->first->sibling) . '\E';
2406 } elsif ($type eq "lc") {
2407 return '\L' . $self->dq($op->first->sibling) . '\E';
2408 } elsif ($type eq "ucfirst") {
2409 return '\u' . $self->dq($op->first->sibling);
2410 } elsif ($type eq "lcfirst") {
2411 return '\l' . $self->dq($op->first->sibling);
2412 } elsif ($type eq "quotemeta") {
2413 return '\Q' . $self->dq($op->first->sibling) . '\E';
2414 } elsif ($type eq "join") {
2415 return $self->deparse($op->last, 26); # was join($", @ary)
2417 return $self->deparse($op, 26);
2425 return single_delim("qx", '`', $self->dq($op->first->sibling));
2431 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2432 return $self->deparse($kid, $cx) if $self->{'unquote'};
2433 $self->maybe_targmy($kid, $cx,
2434 sub {single_delim("qq", '"', $self->dq($_[1]))});
2437 # OP_STRINGIFY is a listop, but it only ever has one arg
2438 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2440 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2441 # note that tr(from)/to/ is OK, but not tr/from/(to)
2443 my($from, $to) = @_;
2444 my($succeed, $delim);
2445 if ($from !~ m[/] and $to !~ m[/]) {
2446 return "/$from/$to/";
2447 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2448 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2451 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2452 return "$from$delim$to$delim" if index($to, $delim) == -1;
2455 return "$from/$to/";
2458 for $delim ('/', '"', '#') { # note no '
2459 return "$delim$from$delim$to$delim"
2460 if index($to . $from, $delim) == -1;
2462 $from =~ s[/][\\/]g;
2464 return "/$from/$to/";
2470 if ($n == ord '\\') {
2472 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2474 } elsif ($n == ord "\a") {
2476 } elsif ($n == ord "\b") {
2478 } elsif ($n == ord "\t") {
2480 } elsif ($n == ord "\n") {
2482 } elsif ($n == ord "\e") {
2484 } elsif ($n == ord "\f") {
2486 } elsif ($n == ord "\r") {
2488 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2489 return '\\c' . chr(ord("@") + $n);
2491 # return '\x' . sprintf("%02x", $n);
2492 return '\\' . sprintf("%03o", $n);
2499 for ($c = 0; $c < @chars; $c++) {
2502 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2503 $chars[$c + 2] == $tr + 2)
2505 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
2508 $str .= pchr($chars[$c]);
2514 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
2517 sub tr_decode_byte {
2518 my($table, $flags) = @_;
2519 my(@table) = unpack("s256", $table);
2520 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2521 if ($table[ord "-"] != -1 and
2522 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2524 $tr = $table[ord "-"];
2525 $table[ord "-"] = -1;
2529 } else { # -2 ==> delete
2533 for ($c = 0; $c < 256; $c++) {
2536 push @from, $c; push @to, $tr;
2537 } elsif ($tr == -2) {
2541 @from = (@from, @delfrom);
2542 if ($flags & OPpTRANS_COMPLEMENT) {
2545 @from{@from} = (1) x @from;
2546 for ($c = 0; $c < 256; $c++) {
2547 push @newfrom, $c unless $from{$c};
2551 unless ($flags & OPpTRANS_DELETE) {
2552 pop @to while $#to and $to[$#to] == $to[$#to -1];
2555 $from = collapse(@from);
2556 $to = collapse(@to);
2557 $from .= "-" if $delhyphen;
2558 return ($from, $to);
2563 if ($x == ord "-") {
2570 # XXX This doesn't yet handle all cases correctly either
2572 sub tr_decode_utf8 {
2573 my($swash_hv, $flags) = @_;
2574 my %swash = $swash_hv->ARRAY;
2576 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
2577 my $none = $swash{"NONE"}->IV;
2578 my $extra = $none + 1;
2579 my(@from, @delfrom, @to);
2581 foreach $line (split /\n/, $swash{'LIST'}->PV) {
2582 my($min, $max, $result) = split(/\t/, $line);
2589 $result = hex $result;
2590 if ($result == $extra) {
2591 push @delfrom, [$min, $max];
2593 push @from, [$min, $max];
2594 push @to, [$result, $result + $max - $min];
2597 for my $i (0 .. $#from) {
2598 if ($from[$i][0] == ord '-') {
2599 unshift @from, splice(@from, $i, 1);
2600 unshift @to, splice(@to, $i, 1);
2602 } elsif ($from[$i][1] == ord '-') {
2605 unshift @from, ord '-';
2606 unshift @to, ord '-';
2610 for my $i (0 .. $#delfrom) {
2611 if ($delfrom[$i][0] == ord '-') {
2612 push @delfrom, splice(@delfrom, $i, 1);
2614 } elsif ($delfrom[$i][1] == ord '-') {
2616 push @delfrom, ord '-';
2620 if (defined $final and $to[$#to][1] != $final) {
2621 push @to, [$final, $final];
2623 push @from, @delfrom;
2624 if ($flags & OPpTRANS_COMPLEMENT) {
2627 for my $i (0 .. $#from) {
2628 push @newfrom, [$next, $from[$i][0] - 1];
2629 $next = $from[$i][1] + 1;
2632 for my $range (@newfrom) {
2633 if ($range->[0] <= $range->[1]) {
2638 my($from, $to, $diff);
2639 for my $chunk (@from) {
2640 $diff = $chunk->[1] - $chunk->[0];
2642 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2643 } elsif ($diff == 1) {
2644 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2646 $from .= tr_chr($chunk->[0]);
2649 for my $chunk (@to) {
2650 $diff = $chunk->[1] - $chunk->[0];
2652 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2653 } elsif ($diff == 1) {
2654 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2656 $to .= tr_chr($chunk->[0]);
2659 #$final = sprintf("%04x", $final) if defined $final;
2660 #$none = sprintf("%04x", $none) if defined $none;
2661 #$extra = sprintf("%04x", $extra) if defined $extra;
2662 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
2663 #print STDERR $swash{'LIST'}->PV;
2664 return (escape_str($from), escape_str($to));
2671 if (class($op) eq "PVOP") {
2672 ($from, $to) = tr_decode_byte($op->pv, $op->private);
2673 } else { # class($op) eq "SVOP"
2674 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
2677 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
2678 $flags .= "d" if $op->private & OPpTRANS_DELETE;
2679 $to = "" if $from eq $to and $flags eq "";
2680 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2681 return "tr" . double_delim($from, $to) . $flags;
2684 # Like dq(), but different
2688 my $type = $op->name;
2689 if ($type eq "const") {
2690 return uninterp($self->const_sv($op)->PV);
2691 } elsif ($type eq "concat") {
2692 return $self->re_dq($op->first) . $self->re_dq($op->last);
2693 } elsif ($type eq "uc") {
2694 return '\U' . $self->re_dq($op->first->sibling) . '\E';
2695 } elsif ($type eq "lc") {
2696 return '\L' . $self->re_dq($op->first->sibling) . '\E';
2697 } elsif ($type eq "ucfirst") {
2698 return '\u' . $self->re_dq($op->first->sibling);
2699 } elsif ($type eq "lcfirst") {
2700 return '\l' . $self->re_dq($op->first->sibling);
2701 } elsif ($type eq "quotemeta") {
2702 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2703 } elsif ($type eq "join") {
2704 return $self->deparse($op->last, 26); # was join($", @ary)
2706 return $self->deparse($op, 26);
2713 my $kid = $op->first;
2714 $kid = $kid->first if $kid->name eq "regcmaybe";
2715 $kid = $kid->first if $kid->name eq "regcreset";
2716 return $self->re_dq($kid);
2719 # osmic acid -- see osmium tetroxide
2722 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2723 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2724 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2728 my($op, $cx, $name, $delim) = @_;
2729 my $kid = $op->first;
2730 my ($binop, $var, $re) = ("", "", "");
2731 if ($op->flags & OPf_STACKED) {
2733 $var = $self->deparse($kid, 20);
2734 $kid = $kid->sibling;
2737 $re = re_uninterp(escape_str($op->precomp));
2739 $re = $self->deparse($kid, 1);
2742 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2743 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2744 $flags .= "i" if $op->pmflags & PMf_FOLD;
2745 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2746 $flags .= "o" if $op->pmflags & PMf_KEEP;
2747 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2748 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2749 $flags = $matchwords{$flags} if $matchwords{$flags};
2750 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2754 $re = single_delim($name, $delim, $re);
2758 return $self->maybe_parens("$var =~ $re", $cx, 20);
2764 sub pp_match { matchop(@_, "m", "/") }
2765 sub pp_pushre { matchop(@_, "m", "/") }
2766 sub pp_qr { matchop(@_, "qr", "") }
2771 my($kid, @exprs, $ary, $expr);
2773 if ($ {$kid->pmreplroot}) {
2774 $ary = '@' . $self->gv_name($kid->pmreplroot);
2776 for (; !null($kid); $kid = $kid->sibling) {
2777 push @exprs, $self->deparse($kid, 6);
2779 $expr = "split(" . join(", ", @exprs) . ")";
2781 return $self->maybe_parens("$ary = $expr", $cx, 7);
2787 # oxime -- any of various compounds obtained chiefly by the action of
2788 # hydroxylamine on aldehydes and ketones and characterized by the
2789 # bivalent grouping C=NOH [Webster's Tenth]
2792 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2793 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2794 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2795 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2800 my $kid = $op->first;
2801 my($binop, $var, $re, $repl) = ("", "", "", "");
2802 if ($op->flags & OPf_STACKED) {
2804 $var = $self->deparse($kid, 20);
2805 $kid = $kid->sibling;
2808 if (null($op->pmreplroot)) {
2809 $repl = $self->dq($kid);
2810 $kid = $kid->sibling;
2812 $repl = $op->pmreplroot->first; # skip substcont
2813 while ($repl->name eq "entereval") {
2814 $repl = $repl->first;
2817 if ($op->pmflags & PMf_EVAL) {
2818 $repl = $self->deparse($repl, 0);
2820 $repl = $self->dq($repl);
2824 $re = re_uninterp(escape_str($op->precomp));
2826 $re = $self->deparse($kid, 1);
2828 $flags .= "e" if $op->pmflags & PMf_EVAL;
2829 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2830 $flags .= "i" if $op->pmflags & PMf_FOLD;
2831 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2832 $flags .= "o" if $op->pmflags & PMf_KEEP;
2833 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2834 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2835 $flags = $substwords{$flags} if $substwords{$flags};
2837 return $self->maybe_parens("$var =~ s"
2838 . double_delim($re, $repl) . $flags,
2841 return "s". double_delim($re, $repl) . $flags;
2850 B::Deparse - Perl compiler backend to produce perl code
2854 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>][B<,-s>I<LETTERS>]
2859 B::Deparse is a backend module for the Perl compiler that generates
2860 perl source code, based on the internal compiled structure that perl
2861 itself creates after parsing a program. The output of B::Deparse won't
2862 be exactly the same as the original source, since perl doesn't keep
2863 track of comments or whitespace, and there isn't a one-to-one
2864 correspondence between perl's syntactical constructions and their
2865 compiled form, but it will often be close. When you use the B<-p>
2866 option, the output also includes parentheses even when they are not
2867 required by precedence, which can make it easy to see if perl is
2868 parsing your expressions the way you intended.
2870 Please note that this module is mainly new and untested code and is
2871 still under development, so it may change in the future.
2875 As with all compiler backend options, these must follow directly after
2876 the '-MO=Deparse', separated by a comma but not any white space.
2882 Add '#line' declarations to the output based on the line and file
2883 locations of the original code.
2887 Print extra parentheses. Without this option, B::Deparse includes
2888 parentheses in its output only when they are needed, based on the
2889 structure of your program. With B<-p>, it uses parentheses (almost)
2890 whenever they would be legal. This can be useful if you are used to
2891 LISP, or if you want to see how perl parses your input. If you say
2893 if ($var & 0x7f == 65) {print "Gimme an A!"}
2894 print ($which ? $a : $b), "\n";
2895 $name = $ENV{USER} or "Bob";
2897 C<B::Deparse,-p> will print
2900 print('Gimme an A!')
2902 (print(($which ? $a : $b)), '???');
2903 (($name = $ENV{'USER'}) or '???')
2905 which probably isn't what you intended (the C<'???'> is a sign that
2906 perl optimized away a constant value).
2910 Expand double-quoted strings into the corresponding combinations of
2911 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
2914 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
2918 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
2919 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
2921 Note that the expanded form represents the way perl handles such
2922 constructions internally -- this option actually turns off the reverse
2923 translation that B::Deparse usually does. On the other hand, note that
2924 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
2925 of $y into a string before doing the assignment.
2927 =item B<-u>I<PACKAGE>
2929 Normally, B::Deparse deparses the main code of a program, all the subs
2930 called by the main program (and all the subs called by them,
2931 recursively), and any other subs in the main:: package. To include
2932 subs in other packages that aren't called directly, such as AUTOLOAD,
2933 DESTROY, other subs called automatically by perl, and methods (which
2934 aren't resolved to subs until runtime), use the B<-u> option. The
2935 argument to B<-u> is the name of a package, and should follow directly
2936 after the 'u'. Multiple B<-u> options may be given, separated by
2937 commas. Note that unlike some other backends, B::Deparse doesn't
2938 (yet) try to guess automatically when B<-u> is needed -- you must
2941 =item B<-s>I<LETTERS>
2943 Tweak the style of B::Deparse's output. The letters should follow
2944 directly after the 's', with no space or punctuation. The following
2945 options are available:
2951 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2968 The default is not to cuddle.
2972 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
2976 Use tabs for each 8 columns of indent. The default is to use only spaces.
2977 For instance, if the style options are B<-si4T>, a line that's indented
2978 3 times will be preceded by one tab and four spaces; if the options were
2979 B<-si8T>, the same line would be preceded by three tabs.
2981 =item B<v>I<STRING>B<.>
2983 Print I<STRING> for the value of a constant that can't be determined
2984 because it was optimized away (mnemonic: this happens when a constant
2985 is used in B<v>oid context). The end of the string is marked by a period.
2986 The string should be a valid perl expression, generally a constant.
2987 Note that unless it's a number, it probably needs to be quoted, and on
2988 a command line quotes need to be protected from the shell. Some
2989 conventional values include 0, 1, 42, '', 'foo', and
2990 'Useless use of constant omitted' (which may need to be
2991 B<-sv"'Useless use of constant omitted'.">
2992 or something similar depending on your shell). The default is '???'.
2993 If you're using B::Deparse on a module or other file that's require'd,
2994 you shouldn't use a value that evaluates to false, since the customary
2995 true constant at the end of a module will be in void context when the
2996 file is compiled as a main program.
3002 =head1 USING B::Deparse AS A MODULE
3007 $deparse = B::Deparse->new("-p", "-sC");
3008 $body = $deparse->coderef2text(\&func);
3009 eval "sub func $body"; # the inverse operation
3013 B::Deparse can also be used on a sub-by-sub basis from other perl
3018 $deparse = B::Deparse->new(OPTIONS)
3020 Create an object to store the state of a deparsing operation and any
3021 options. The options are the same as those that can be given on the
3022 command line (see L</OPTIONS>); options that are separated by commas
3023 after B<-MO=Deparse> should be given as separate strings. Some
3024 options, like B<-u>, don't make sense for a single subroutine, so
3029 $body = $deparse->coderef2text(\&func)
3030 $body = $deparse->coderef2text(sub ($$) { ... })
3032 Return source code for the body of a subroutine (a block, optionally
3033 preceded by a prototype in parens), given a reference to the
3034 sub. Because a subroutine can have no names, or more than one name,
3035 this method doesn't return a complete subroutine definition -- if you
3036 want to eval the result, you should prepend "sub subname ", or "sub "
3037 for an anonymous function constructor. Unless the sub was defined in
3038 the main:: package, the code will include a package declaration.
3042 See the 'to do' list at the beginning of the module file.
3046 Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier
3047 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3048 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3049 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.