2 # Copyright (c) 1998, 1999 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';
12 use B qw(class main_root main_start main_cv svref_2object opnumber
13 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
14 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
15 OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
16 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
17 SVf_IOK SVf_NOK SVf_ROK SVf_POK
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->maybe_padgv($op);
256 if ($op->next->name eq "entersub") {
257 next if $self->{'subs_done'}{$$gv}++;
258 next 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 next if $self->{'forms_done'}{$$gv}++;
265 next 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 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 local($self->{'curcv'}) = $cv;
437 local($self->{'curstash'}) = $self->{'curstash'};
438 if (not null $cv->ROOT) {
440 return $proto . "{\n\t" .
441 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
443 return $proto . "{}\n";
451 local($self->{'curcv'}) = $form;
452 local($self->{'curstash'}) = $self->{'curstash'};
453 my $op = $form->ROOT;
455 $op = $op->first->first; # skip leavewrite, lineseq
456 while (not null $op) {
457 $op = $op->sibling; # skip nextstate
459 $kid = $op->first->sibling; # skip pushmark
460 push @text, $self->const_sv($kid)->PV;
461 $kid = $kid->sibling;
462 for (; not null $kid; $kid = $kid->sibling) {
463 push @exprs, $self->deparse($kid, 0);
465 push @text, join(", ", @exprs)."\n" if @exprs;
468 return join("", @text) . ".";
473 return $op->name eq "leave" || $op->name eq "scope"
474 || $op->name eq "lineseq"
475 || ($op->name eq "null" && class($op) eq "UNOP"
476 && (is_scope($op->first) || $op->first->name eq "enter"));
480 my $name = $_[0]->name;
481 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
484 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
486 return (!null($op) and null($op->sibling)
487 and $op->name eq "null" and class($op) eq "UNOP"
488 and (($op->first->name =~ /^(and|or)$/
489 and $op->first->first->sibling->name eq "lineseq")
490 or ($op->first->name eq "lineseq"
491 and not null $op->first->first->sibling
492 and $op->first->first->sibling->name eq "unstack")
498 return ($op->name eq "rv2sv" or
499 $op->name eq "padsv" or
500 $op->name eq "gv" or # only in array/hash constructs
501 $op->flags & OPf_KIDS && !null($op->first)
502 && $op->first->name eq "gvsv");
507 my($text, $cx, $prec) = @_;
508 if ($prec < $cx # unary ops nest just fine
509 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
510 or $self->{'parens'})
513 # In a unop, let parent reuse our parens; see maybe_parens_unop
514 $text = "\cS" . $text if $cx == 16;
521 # same as above, but get around the `if it looks like a function' rule
522 sub maybe_parens_unop {
524 my($name, $kid, $cx) = @_;
525 if ($cx > 16 or $self->{'parens'}) {
526 return "$name(" . $self->deparse($kid, 1) . ")";
528 $kid = $self->deparse($kid, 16);
529 if (substr($kid, 0, 1) eq "\cS") {
531 return $name . substr($kid, 1);
532 } elsif (substr($kid, 0, 1) eq "(") {
533 # avoid looks-like-a-function trap with extra parens
534 # (`+' can lead to ambiguities)
535 return "$name(" . $kid . ")";
542 sub maybe_parens_func {
544 my($func, $text, $cx, $prec) = @_;
545 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
546 return "$func($text)";
548 return "$func $text";
554 my($op, $cx, $text) = @_;
555 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
556 return $self->maybe_parens_func("local", $text, $cx, 16);
564 my($op, $cx, $func, @args) = @_;
565 if ($op->private & OPpTARGET_MY) {
566 my $var = $self->padname($op->targ);
567 my $val = $func->($self, $op, 7, @args);
568 return $self->maybe_parens("$var = $val", $cx, 7);
570 return $func->($self, $op, $cx, @args);
577 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
582 my($op, $cx, $text) = @_;
583 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
584 return $self->maybe_parens_func("my", $text, $cx, 16);
590 # The following OPs don't have functions:
592 # pp_padany -- does not exist after parsing
593 # pp_rcatline -- does not exist
595 sub pp_enter { # see also leave
596 cluck "unexpected OP_ENTER";
600 sub pp_pushmark { # see also list
601 cluck "unexpected OP_PUSHMARK";
605 sub pp_leavesub { # see also deparse_sub
606 cluck "unexpected OP_LEAVESUB";
610 sub pp_leavewrite { # see also deparse_format
611 cluck "unexpected OP_LEAVEWRITE";
615 sub pp_method { # see also entersub
616 cluck "unexpected OP_METHOD";
620 sub pp_regcmaybe { # see also regcomp
621 cluck "unexpected OP_REGCMAYBE";
625 sub pp_regcreset { # see also regcomp
626 cluck "unexpected OP_REGCRESET";
630 sub pp_substcont { # see also subst
631 cluck "unexpected OP_SUBSTCONT";
635 sub pp_grepstart { # see also grepwhile
636 cluck "unexpected OP_GREPSTART";
640 sub pp_mapstart { # see also mapwhile
641 cluck "unexpected OP_MAPSTART";
645 sub pp_flip { # see also flop
646 cluck "unexpected OP_FLIP";
650 sub pp_iter { # see also leaveloop
651 cluck "unexpected OP_ITER";
655 sub pp_enteriter { # see also leaveloop
656 cluck "unexpected OP_ENTERITER";
660 sub pp_enterloop { # see also leaveloop
661 cluck "unexpected OP_ENTERLOOP";
665 sub pp_leaveeval { # see also entereval
666 cluck "unexpected OP_LEAVEEVAL";
670 sub pp_entertry { # see also leavetry
671 cluck "unexpected OP_ENTERTRY";
675 # leave and scope/lineseq should probably share code
681 local($self->{'curstash'}) = $self->{'curstash'};
682 $kid = $op->first->sibling; # skip enter
683 if (is_miniwhile($kid)) {
684 my $top = $kid->first;
685 my $name = $top->name;
686 if ($name eq "and") {
688 } elsif ($name eq "or") {
690 } else { # no conditional -> while 1 or until 0
691 return $self->deparse($top->first, 1) . " while 1";
693 my $cond = $top->first;
694 my $body = $cond->sibling->first; # skip lineseq
695 $cond = $self->deparse($cond, 1);
696 $body = $self->deparse($body, 1);
697 return "$body $name $cond";
699 for (; !null($kid); $kid = $kid->sibling) {
702 $expr = $self->deparse($kid, 0);
703 $kid = $kid->sibling;
706 $expr .= $self->deparse($kid, 0);
707 push @exprs, $expr if length $expr;
709 if ($cx > 0) { # inside an expression
710 return "do { " . join(";\n", @exprs) . " }";
712 return join(";\n", @exprs) . ";";
721 for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
724 $expr = $self->deparse($kid, 0);
725 $kid = $kid->sibling;
728 $expr .= $self->deparse($kid, 0);
729 push @exprs, $expr if length $expr;
731 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
732 return "do { " . join(";\n", @exprs) . " }";
734 return join(";\n", @exprs) . ";";
738 sub pp_lineseq { pp_scope(@_) }
740 # The BEGIN {} is used here because otherwise this code isn't executed
741 # when you run B::Deparse on itself.
743 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
744 "ENV", "ARGV", "ARGVOUT", "_"); }
749 my $stash = $gv->STASH->NAME;
750 my $name = $gv->NAME;
751 if ($stash eq $self->{'curstash'} or $globalnames{$name}
752 or $name =~ /^[^A-Za-z_]/)
756 $stash = $stash . "::";
758 if ($name =~ /^([\cA-\cZ])$/) {
759 $name = "^" . chr(64 + ord($1));
761 return $stash . $name;
764 # Notice how subs and formats are inserted between statements here
769 @text = $op->label . ": " if $op->label;
770 my $seq = $op->cop_seq;
771 while (scalar(@{$self->{'subs_todo'}})
772 and $seq > $self->{'subs_todo'}[0][0]) {
773 push @text, $self->next_todo;
775 my $stash = $op->stashpv;
776 if ($stash ne $self->{'curstash'}) {
777 push @text, "package $stash;\n";
778 $self->{'curstash'} = $stash;
780 if ($self->{'linenums'}) {
781 push @text, "\f#line " . $op->line .
782 ' "' . $op->file, qq'"\n';
784 return join("", @text);
787 sub pp_dbstate { pp_nextstate(@_) }
788 sub pp_setstate { pp_nextstate(@_) }
790 sub pp_unstack { return "" } # see also leaveloop
794 my($op, $cx, $name) = @_;
798 sub pp_stub { baseop(@_, "()") }
799 sub pp_wantarray { baseop(@_, "wantarray") }
800 sub pp_fork { baseop(@_, "fork") }
801 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
802 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
803 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
804 sub pp_tms { baseop(@_, "times") }
805 sub pp_ghostent { baseop(@_, "gethostent") }
806 sub pp_gnetent { baseop(@_, "getnetent") }
807 sub pp_gprotoent { baseop(@_, "getprotoent") }
808 sub pp_gservent { baseop(@_, "getservent") }
809 sub pp_ehostent { baseop(@_, "endhostent") }
810 sub pp_enetent { baseop(@_, "endnetent") }
811 sub pp_eprotoent { baseop(@_, "endprotoent") }
812 sub pp_eservent { baseop(@_, "endservent") }
813 sub pp_gpwent { baseop(@_, "getpwent") }
814 sub pp_spwent { baseop(@_, "setpwent") }
815 sub pp_epwent { baseop(@_, "endpwent") }
816 sub pp_ggrent { baseop(@_, "getgrent") }
817 sub pp_sgrent { baseop(@_, "setgrent") }
818 sub pp_egrent { baseop(@_, "endgrent") }
819 sub pp_getlogin { baseop(@_, "getlogin") }
823 # I couldn't think of a good short name, but this is the category of
824 # symbolic unary operators with interesting precedence
828 my($op, $cx, $name, $prec, $flags) = (@_, 0);
829 my $kid = $op->first;
830 $kid = $self->deparse($kid, $prec);
831 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
835 sub pp_preinc { pfixop(@_, "++", 23) }
836 sub pp_predec { pfixop(@_, "--", 23) }
837 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
838 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
839 sub pp_i_preinc { pfixop(@_, "++", 23) }
840 sub pp_i_predec { pfixop(@_, "--", 23) }
841 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
842 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
843 sub pp_complement { maybe_targmy(@_. \&pfixop, "~", 21) }
845 sub pp_negate { maybe_targmy(@_, \&real_negate) }
849 if ($op->first->name =~ /^(i_)?negate$/) {
851 $self->pfixop($op, $cx, "-", 21.5);
853 $self->pfixop($op, $cx, "-", 21);
856 sub pp_i_negate { pp_negate(@_) }
862 $self->pfixop($op, $cx, "not ", 4);
864 $self->pfixop($op, $cx, "!", 21);
870 my($op, $cx, $name) = @_;
872 if ($op->flags & OPf_KIDS) {
874 return $self->maybe_parens_unop($name, $kid, $cx);
876 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
880 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
881 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
882 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
883 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
884 sub pp_defined { unop(@_, "defined") }
885 sub pp_undef { unop(@_, "undef") }
886 sub pp_study { unop(@_, "study") }
887 sub pp_ref { unop(@_, "ref") }
888 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
890 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
891 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
892 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
893 sub pp_srand { unop(@_, "srand") }
894 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
895 sub pp_log { maybe_targmy(@_, \&unop, "log") }
896 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
897 sub pp_int { maybe_targmy(@_, \&unop, "int") }
898 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
899 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
900 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
902 sub pp_length { maybe_targmy(@_, \&unop, "length") }
903 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
904 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
906 sub pp_each { unop(@_, "each") }
907 sub pp_values { unop(@_, "values") }
908 sub pp_keys { unop(@_, "keys") }
909 sub pp_pop { unop(@_, "pop") }
910 sub pp_shift { unop(@_, "shift") }
912 sub pp_caller { unop(@_, "caller") }
913 sub pp_reset { unop(@_, "reset") }
914 sub pp_exit { unop(@_, "exit") }
915 sub pp_prototype { unop(@_, "prototype") }
917 sub pp_close { unop(@_, "close") }
918 sub pp_fileno { unop(@_, "fileno") }
919 sub pp_umask { unop(@_, "umask") }
920 sub pp_binmode { unop(@_, "binmode") }
921 sub pp_untie { unop(@_, "untie") }
922 sub pp_tied { unop(@_, "tied") }
923 sub pp_dbmclose { unop(@_, "dbmclose") }
924 sub pp_getc { unop(@_, "getc") }
925 sub pp_eof { unop(@_, "eof") }
926 sub pp_tell { unop(@_, "tell") }
927 sub pp_getsockname { unop(@_, "getsockname") }
928 sub pp_getpeername { unop(@_, "getpeername") }
930 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
931 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
932 sub pp_readlink { unop(@_, "readlink") }
933 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
934 sub pp_readdir { unop(@_, "readdir") }
935 sub pp_telldir { unop(@_, "telldir") }
936 sub pp_rewinddir { unop(@_, "rewinddir") }
937 sub pp_closedir { unop(@_, "closedir") }
938 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
939 sub pp_localtime { unop(@_, "localtime") }
940 sub pp_gmtime { unop(@_, "gmtime") }
941 sub pp_alarm { unop(@_, "alarm") }
942 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
944 sub pp_dofile { unop(@_, "do") }
945 sub pp_entereval { unop(@_, "eval") }
947 sub pp_ghbyname { unop(@_, "gethostbyname") }
948 sub pp_gnbyname { unop(@_, "getnetbyname") }
949 sub pp_gpbyname { unop(@_, "getprotobyname") }
950 sub pp_shostent { unop(@_, "sethostent") }
951 sub pp_snetent { unop(@_, "setnetent") }
952 sub pp_sprotoent { unop(@_, "setprotoent") }
953 sub pp_sservent { unop(@_, "setservent") }
954 sub pp_gpwnam { unop(@_, "getpwnam") }
955 sub pp_gpwuid { unop(@_, "getpwuid") }
956 sub pp_ggrnam { unop(@_, "getgrnam") }
957 sub pp_ggrgid { unop(@_, "getgrgid") }
959 sub pp_lock { unop(@_, "lock") }
964 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
972 if ($op->private & OPpSLICE) {
973 return $self->maybe_parens_func("delete",
974 $self->pp_hslice($op->first, 16),
977 return $self->maybe_parens_func("delete",
978 $self->pp_helem($op->first, 16),
986 if (class($op) eq "UNOP" and $op->first->name eq "const"
987 and $op->first->private & OPpCONST_BARE)
989 my $name = $self->const_sv($op->first)->PV;
992 return "require($name)";
994 $self->unop($op, $cx, "require");
1001 my $kid = $op->first;
1002 if (not null $kid->sibling) {
1003 # XXX Was a here-doc
1004 return $self->dquote($op);
1006 $self->unop(@_, "scalar");
1013 #cluck "curcv was undef" unless $self->{curcv};
1014 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1020 my $kid = $op->first;
1021 if ($kid->name eq "null") {
1023 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1024 my($pre, $post) = @{{"anonlist" => ["[","]"],
1025 "anonhash" => ["{","}"]}->{$kid->name}};
1027 $kid = $kid->first->sibling; # skip pushmark
1028 for (; !null($kid); $kid = $kid->sibling) {
1029 $expr = $self->deparse($kid, 6);
1032 return $pre . join(", ", @exprs) . $post;
1033 } elsif (!null($kid->sibling) and
1034 $kid->sibling->name eq "anoncode") {
1036 $self->deparse_sub($self->padval($kid->sibling->targ));
1037 } elsif ($kid->name eq "pushmark") {
1038 my $sib_name = $kid->sibling->name;
1039 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1040 and not $kid->sibling->flags & OPf_REF)
1042 # The @a in \(@a) isn't in ref context, but only when the
1044 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1045 } elsif ($sib_name eq 'entersub') {
1046 my $text = $self->deparse($kid->sibling, 1);
1047 # Always show parens for \(&func()), but only with -p otherwise
1048 $text = "($text)" if $self->{'parens'}
1049 or $kid->sibling->private & OPpENTERSUB_AMPER;
1054 $self->pfixop($op, $cx, "\\", 20);
1057 sub pp_srefgen { pp_refgen(@_) }
1062 my $kid = $op->first;
1063 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1064 return "<" . $self->deparse($kid, 1) . ">";
1067 # Unary operators that can occur as pseudo-listops inside double quotes
1070 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1072 if ($op->flags & OPf_KIDS) {
1074 # If there's more than one kid, the first is an ex-pushmark.
1075 $kid = $kid->sibling if not null $kid->sibling;
1076 return $self->maybe_parens_unop($name, $kid, $cx);
1078 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1082 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1083 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1084 sub pp_uc { dq_unop(@_, "uc") }
1085 sub pp_lc { dq_unop(@_, "lc") }
1086 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1090 my ($op, $cx, $name) = @_;
1091 if (class($op) eq "PVOP") {
1092 return "$name " . $op->pv;
1093 } elsif (class($op) eq "OP") {
1095 } elsif (class($op) eq "UNOP") {
1096 # Note -- loop exits are actually exempt from the
1097 # looks-like-a-func rule, but a few extra parens won't hurt
1098 return $self->maybe_parens_unop($name, $op->first, $cx);
1102 sub pp_last { loopex(@_, "last") }
1103 sub pp_next { loopex(@_, "next") }
1104 sub pp_redo { loopex(@_, "redo") }
1105 sub pp_goto { loopex(@_, "goto") }
1106 sub pp_dump { loopex(@_, "dump") }
1110 my($op, $cx, $name) = @_;
1111 if (class($op) eq "UNOP") {
1112 # Genuine `-X' filetests are exempt from the LLAFR, but not
1113 # l?stat(); for the sake of clarity, give'em all parens
1114 return $self->maybe_parens_unop($name, $op->first, $cx);
1115 } elsif (class($op) eq "SVOP") {
1116 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1117 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1122 sub pp_lstat { ftst(@_, "lstat") }
1123 sub pp_stat { ftst(@_, "stat") }
1124 sub pp_ftrread { ftst(@_, "-R") }
1125 sub pp_ftrwrite { ftst(@_, "-W") }
1126 sub pp_ftrexec { ftst(@_, "-X") }
1127 sub pp_fteread { ftst(@_, "-r") }
1128 sub pp_ftewrite { ftst(@_, "-r") }
1129 sub pp_fteexec { ftst(@_, "-r") }
1130 sub pp_ftis { ftst(@_, "-e") }
1131 sub pp_fteowned { ftst(@_, "-O") }
1132 sub pp_ftrowned { ftst(@_, "-o") }
1133 sub pp_ftzero { ftst(@_, "-z") }
1134 sub pp_ftsize { ftst(@_, "-s") }
1135 sub pp_ftmtime { ftst(@_, "-M") }
1136 sub pp_ftatime { ftst(@_, "-A") }
1137 sub pp_ftctime { ftst(@_, "-C") }
1138 sub pp_ftsock { ftst(@_, "-S") }
1139 sub pp_ftchr { ftst(@_, "-c") }
1140 sub pp_ftblk { ftst(@_, "-b") }
1141 sub pp_ftfile { ftst(@_, "-f") }
1142 sub pp_ftdir { ftst(@_, "-d") }
1143 sub pp_ftpipe { ftst(@_, "-p") }
1144 sub pp_ftlink { ftst(@_, "-l") }
1145 sub pp_ftsuid { ftst(@_, "-u") }
1146 sub pp_ftsgid { ftst(@_, "-g") }
1147 sub pp_ftsvtx { ftst(@_, "-k") }
1148 sub pp_fttty { ftst(@_, "-t") }
1149 sub pp_fttext { ftst(@_, "-T") }
1150 sub pp_ftbinary { ftst(@_, "-B") }
1152 sub SWAP_CHILDREN () { 1 }
1153 sub ASSIGN () { 2 } # has OP= variant
1159 my $name = $op->name;
1160 if ($name eq "concat" and $op->first->name eq "concat") {
1161 # avoid spurious `=' -- see comment in pp_concat
1164 if ($name eq "null" and class($op) eq "UNOP"
1165 and $op->first->name =~ /^(and|x?or)$/
1166 and null $op->first->sibling)
1168 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1169 # with a null that's used as the common end point of the two
1170 # flows of control. For precedence purposes, ignore it.
1171 # (COND_EXPRs have these too, but we don't bother with
1172 # their associativity).
1173 return assoc_class($op->first);
1175 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1178 # Left associative operators, like `+', for which
1179 # $a + $b + $c is equivalent to ($a + $b) + $c
1182 %left = ('multiply' => 19, 'i_multiply' => 19,
1183 'divide' => 19, 'i_divide' => 19,
1184 'modulo' => 19, 'i_modulo' => 19,
1186 'add' => 18, 'i_add' => 18,
1187 'subtract' => 18, 'i_subtract' => 18,
1189 'left_shift' => 17, 'right_shift' => 17,
1191 'bit_or' => 12, 'bit_xor' => 12,
1193 'or' => 2, 'xor' => 2,
1197 sub deparse_binop_left {
1199 my($op, $left, $prec) = @_;
1200 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1201 and $left{assoc_class($op)} == $left{assoc_class($left)})
1203 return $self->deparse($left, $prec - .00001);
1205 return $self->deparse($left, $prec);
1209 # Right associative operators, like `=', for which
1210 # $a = $b = $c is equivalent to $a = ($b = $c)
1213 %right = ('pow' => 22,
1214 'sassign=' => 7, 'aassign=' => 7,
1215 'multiply=' => 7, 'i_multiply=' => 7,
1216 'divide=' => 7, 'i_divide=' => 7,
1217 'modulo=' => 7, 'i_modulo=' => 7,
1219 'add=' => 7, 'i_add=' => 7,
1220 'subtract=' => 7, 'i_subtract=' => 7,
1222 'left_shift=' => 7, 'right_shift=' => 7,
1224 'bit_or=' => 7, 'bit_xor=' => 7,
1230 sub deparse_binop_right {
1232 my($op, $right, $prec) = @_;
1233 if ($right{assoc_class($op)} && $right{assoc_class($right)}
1234 and $right{assoc_class($op)} == $right{assoc_class($right)})
1236 return $self->deparse($right, $prec - .00001);
1238 return $self->deparse($right, $prec);
1244 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1245 my $left = $op->first;
1246 my $right = $op->last;
1248 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1252 if ($flags & SWAP_CHILDREN) {
1253 ($left, $right) = ($right, $left);
1255 $left = $self->deparse_binop_left($op, $left, $prec);
1256 $right = $self->deparse_binop_right($op, $right, $prec);
1257 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1260 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1261 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1262 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1263 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1264 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1265 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1266 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1267 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1268 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1269 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1270 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1272 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1273 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1274 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1275 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1276 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1278 sub pp_eq { binop(@_, "==", 14) }
1279 sub pp_ne { binop(@_, "!=", 14) }
1280 sub pp_lt { binop(@_, "<", 15) }
1281 sub pp_gt { binop(@_, ">", 15) }
1282 sub pp_ge { binop(@_, ">=", 15) }
1283 sub pp_le { binop(@_, "<=", 15) }
1284 sub pp_ncmp { binop(@_, "<=>", 14) }
1285 sub pp_i_eq { binop(@_, "==", 14) }
1286 sub pp_i_ne { binop(@_, "!=", 14) }
1287 sub pp_i_lt { binop(@_, "<", 15) }
1288 sub pp_i_gt { binop(@_, ">", 15) }
1289 sub pp_i_ge { binop(@_, ">=", 15) }
1290 sub pp_i_le { binop(@_, "<=", 15) }
1291 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1293 sub pp_seq { binop(@_, "eq", 14) }
1294 sub pp_sne { binop(@_, "ne", 14) }
1295 sub pp_slt { binop(@_, "lt", 15) }
1296 sub pp_sgt { binop(@_, "gt", 15) }
1297 sub pp_sge { binop(@_, "ge", 15) }
1298 sub pp_sle { binop(@_, "le", 15) }
1299 sub pp_scmp { binop(@_, "cmp", 14) }
1301 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1302 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1304 # `.' is special because concats-of-concats are optimized to save copying
1305 # by making all but the first concat stacked. The effect is as if the
1306 # programmer had written `($a . $b) .= $c', except legal.
1307 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1311 my $left = $op->first;
1312 my $right = $op->last;
1315 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1319 $left = $self->deparse_binop_left($op, $left, $prec);
1320 $right = $self->deparse_binop_right($op, $right, $prec);
1321 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1324 # `x' is weird when the left arg is a list
1328 my $left = $op->first;
1329 my $right = $op->last;
1332 if ($op->flags & OPf_STACKED) {
1336 if (null($right)) { # list repeat; count is inside left-side ex-list
1337 my $kid = $left->first->sibling; # skip pushmark
1339 for (; !null($kid->sibling); $kid = $kid->sibling) {
1340 push @exprs, $self->deparse($kid, 6);
1343 $left = "(" . join(", ", @exprs). ")";
1345 $left = $self->deparse_binop_left($op, $left, $prec);
1347 $right = $self->deparse_binop_right($op, $right, $prec);
1348 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1353 my ($op, $cx, $type) = @_;
1354 my $left = $op->first;
1355 my $right = $left->sibling;
1356 $left = $self->deparse($left, 9);
1357 $right = $self->deparse($right, 9);
1358 return $self->maybe_parens("$left $type $right", $cx, 9);
1364 my $flip = $op->first;
1365 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1366 return $self->range($flip->first, $cx, $type);
1369 # one-line while/until is handled in pp_leave
1373 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1374 my $left = $op->first;
1375 my $right = $op->first->sibling;
1376 if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
1377 $left = $self->deparse($left, 1);
1378 $right = $self->deparse($right, 0);
1379 return "$blockname ($left) {\n\t$right\n\b}\cK";
1380 } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
1381 $right = $self->deparse($right, 1);
1382 $left = $self->deparse($left, 1);
1383 return "$right $blockname $left";
1384 } elsif ($cx > $lowprec and $highop) { # $a && $b
1385 $left = $self->deparse_binop_left($op, $left, $highprec);
1386 $right = $self->deparse_binop_right($op, $right, $highprec);
1387 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1388 } else { # $a and $b
1389 $left = $self->deparse_binop_left($op, $left, $lowprec);
1390 $right = $self->deparse_binop_right($op, $right, $lowprec);
1391 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1395 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1396 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1398 # xor is syntactically a logop, but it's really a binop (contrary to
1399 # old versions of opcode.pl). Syntax is what matters here.
1400 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1404 my ($op, $cx, $opname) = @_;
1405 my $left = $op->first;
1406 my $right = $op->first->sibling->first; # skip sassign
1407 $left = $self->deparse($left, 7);
1408 $right = $self->deparse($right, 7);
1409 return $self->maybe_parens("$left $opname $right", $cx, 7);
1412 sub pp_andassign { logassignop(@_, "&&=") }
1413 sub pp_orassign { logassignop(@_, "||=") }
1417 my($op, $cx, $name) = @_;
1419 my $parens = ($cx >= 5) || $self->{'parens'};
1420 my $kid = $op->first->sibling;
1421 return $name if null $kid;
1422 my $first = $self->deparse($kid, 6);
1423 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1424 push @exprs, $first;
1425 $kid = $kid->sibling;
1426 for (; !null($kid); $kid = $kid->sibling) {
1427 push @exprs, $self->deparse($kid, 6);
1430 return "$name(" . join(", ", @exprs) . ")";
1432 return "$name " . join(", ", @exprs);
1436 sub pp_bless { listop(@_, "bless") }
1437 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
1438 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1439 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1440 sub pp_index { maybe_targmy(@_, \&listop, "index") }
1441 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
1442 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
1443 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1444 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
1445 sub pp_unpack { listop(@_, "unpack") }
1446 sub pp_pack { listop(@_, "pack") }
1447 sub pp_join { maybe_targmy(@_, \&listop, "join") }
1448 sub pp_splice { listop(@_, "splice") }
1449 sub pp_push { maybe_targmy(@_, \&listop, "push") }
1450 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
1451 sub pp_reverse { listop(@_, "reverse") }
1452 sub pp_warn { listop(@_, "warn") }
1453 sub pp_die { listop(@_, "die") }
1454 # Actually, return is exempt from the LLAFR (see examples in this very
1455 # module!), but for consistency's sake, ignore that fact
1456 sub pp_return { listop(@_, "return") }
1457 sub pp_open { listop(@_, "open") }
1458 sub pp_pipe_op { listop(@_, "pipe") }
1459 sub pp_tie { listop(@_, "tie") }
1460 sub pp_dbmopen { listop(@_, "dbmopen") }
1461 sub pp_sselect { listop(@_, "select") }
1462 sub pp_select { listop(@_, "select") }
1463 sub pp_read { listop(@_, "read") }
1464 sub pp_sysopen { listop(@_, "sysopen") }
1465 sub pp_sysseek { listop(@_, "sysseek") }
1466 sub pp_sysread { listop(@_, "sysread") }
1467 sub pp_syswrite { listop(@_, "syswrite") }
1468 sub pp_send { listop(@_, "send") }
1469 sub pp_recv { listop(@_, "recv") }
1470 sub pp_seek { listop(@_, "seek") }
1471 sub pp_fcntl { listop(@_, "fcntl") }
1472 sub pp_ioctl { listop(@_, "ioctl") }
1473 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
1474 sub pp_socket { listop(@_, "socket") }
1475 sub pp_sockpair { listop(@_, "sockpair") }
1476 sub pp_bind { listop(@_, "bind") }
1477 sub pp_connect { listop(@_, "connect") }
1478 sub pp_listen { listop(@_, "listen") }
1479 sub pp_accept { listop(@_, "accept") }
1480 sub pp_shutdown { listop(@_, "shutdown") }
1481 sub pp_gsockopt { listop(@_, "getsockopt") }
1482 sub pp_ssockopt { listop(@_, "setsockopt") }
1483 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
1484 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
1485 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
1486 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
1487 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
1488 sub pp_link { maybe_targmy(@_, \&listop, "link") }
1489 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
1490 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
1491 sub pp_open_dir { listop(@_, "opendir") }
1492 sub pp_seekdir { listop(@_, "seekdir") }
1493 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
1494 sub pp_system { maybe_targmy(@_, \&listop, "system") }
1495 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
1496 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
1497 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
1498 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
1499 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
1500 sub pp_shmget { listop(@_, "shmget") }
1501 sub pp_shmctl { listop(@_, "shmctl") }
1502 sub pp_shmread { listop(@_, "shmread") }
1503 sub pp_shmwrite { listop(@_, "shmwrite") }
1504 sub pp_msgget { listop(@_, "msgget") }
1505 sub pp_msgctl { listop(@_, "msgctl") }
1506 sub pp_msgsnd { listop(@_, "msgsnd") }
1507 sub pp_msgrcv { listop(@_, "msgrcv") }
1508 sub pp_semget { listop(@_, "semget") }
1509 sub pp_semctl { listop(@_, "semctl") }
1510 sub pp_semop { listop(@_, "semop") }
1511 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1512 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1513 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1514 sub pp_gsbyname { listop(@_, "getservbyname") }
1515 sub pp_gsbyport { listop(@_, "getservbyport") }
1516 sub pp_syscall { listop(@_, "syscall") }
1521 my $text = $self->dq($op->first->sibling); # skip pushmark
1522 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1523 or $text =~ /[<>]/) {
1524 return 'glob(' . single_delim('qq', '"', $text) . ')';
1526 return '<' . $text . '>';
1530 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1531 # be a filehandle. This could probably be better fixed in the core
1532 # by moving the GV lookup into ck_truc.
1538 my $parens = ($cx >= 5) || $self->{'parens'};
1539 my $kid = $op->first->sibling;
1541 if ($op->flags & OPf_SPECIAL) {
1542 # $kid is an OP_CONST
1543 $fh = $self->const_sv($kid)->PV;
1545 $fh = $self->deparse($kid, 6);
1546 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1548 my $len = $self->deparse($kid->sibling, 6);
1550 return "truncate($fh, $len)";
1552 return "truncate $fh, $len";
1558 my($op, $cx, $name) = @_;
1560 my $kid = $op->first->sibling;
1562 if ($op->flags & OPf_STACKED) {
1564 $indir = $indir->first; # skip rv2gv
1565 if (is_scope($indir)) {
1566 $indir = "{" . $self->deparse($indir, 0) . "}";
1568 $indir = $self->deparse($indir, 24);
1570 $indir = $indir . " ";
1571 $kid = $kid->sibling;
1573 for (; !null($kid); $kid = $kid->sibling) {
1574 $expr = $self->deparse($kid, 6);
1577 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
1581 sub pp_prtf { indirop(@_, "printf") }
1582 sub pp_print { indirop(@_, "print") }
1583 sub pp_sort { indirop(@_, "sort") }
1587 my($op, $cx, $name) = @_;
1589 my $kid = $op->first; # this is the (map|grep)start
1590 $kid = $kid->first->sibling; # skip a pushmark
1591 my $code = $kid->first; # skip a null
1592 if (is_scope $code) {
1593 $code = "{" . $self->deparse($code, 0) . "} ";
1595 $code = $self->deparse($code, 24) . ", ";
1597 $kid = $kid->sibling;
1598 for (; !null($kid); $kid = $kid->sibling) {
1599 $expr = $self->deparse($kid, 6);
1600 push @exprs, $expr if $expr;
1602 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1605 sub pp_mapwhile { mapop(@_, "map") }
1606 sub pp_grepwhile { mapop(@_, "grep") }
1612 my $kid = $op->first->sibling; # skip pushmark
1614 my $local = "either"; # could be local(...) or my(...)
1615 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1616 # This assumes that no other private flags equal 128, and that
1617 # OPs that store things other than flags in their op_private,
1618 # like OP_AELEMFAST, won't be immediate children of a list.
1619 unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
1621 $local = ""; # or not
1624 if ($lop->name =~ /^pad[ash]v$/) { # my()
1625 ($local = "", last) if $local eq "local";
1627 } elsif ($lop->name ne "undef") { # local()
1628 ($local = "", last) if $local eq "my";
1632 $local = "" if $local eq "either"; # no point if it's all undefs
1633 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
1634 for (; !null($kid); $kid = $kid->sibling) {
1636 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
1641 $self->{'avoid_local'}{$$lop}++;
1642 $expr = $self->deparse($kid, 6);
1643 delete $self->{'avoid_local'}{$$lop};
1645 $expr = $self->deparse($kid, 6);
1650 return "$local(" . join(", ", @exprs) . ")";
1652 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1659 my $cond = $op->first;
1660 my $true = $cond->sibling;
1661 my $false = $true->sibling;
1662 my $cuddle = $self->{'cuddle'};
1663 unless ($cx == 0 and is_scope($true) and is_scope($false)) {
1664 $cond = $self->deparse($cond, 8);
1665 $true = $self->deparse($true, 8);
1666 $false = $self->deparse($false, 8);
1667 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1669 $cond = $self->deparse($cond, 1);
1670 $true = $self->deparse($true, 0);
1671 if ($false->name eq "lineseq") { # braces w/o scope => elsif
1672 my $head = "if ($cond) {\n\t$true\n\b}";
1674 while (!null($false) and $false->name eq "lineseq") {
1675 my $newop = $false->first->sibling->first;
1676 my $newcond = $newop->first;
1677 my $newtrue = $newcond->sibling;
1678 $false = $newtrue->sibling; # last in chain is OP_AND => no else
1679 $newcond = $self->deparse($newcond, 1);
1680 $newtrue = $self->deparse($newtrue, 0);
1681 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1683 if (!null($false)) {
1684 $false = $cuddle . "else {\n\t" .
1685 $self->deparse($false, 0) . "\n\b}\cK";
1689 return $head . join($cuddle, "", @elsifs) . $false;
1691 $false = $self->deparse($false, 0);
1692 return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK";
1698 my $enter = $op->first;
1699 my $kid = $enter->sibling;
1700 local($self->{'curstash'}) = $self->{'curstash'};
1703 if ($kid->name eq "lineseq") { # bare or infinite loop
1704 if (is_state $kid->last) { # infinite
1705 $head = "for (;;) "; # shorter than while (1)
1709 } elsif ($enter->name eq "enteriter") { # foreach
1710 my $ary = $enter->first->sibling; # first was pushmark
1711 my $var = $ary->sibling;
1712 if ($enter->flags & OPf_STACKED
1713 and not null $ary->first->sibling->sibling)
1715 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1716 $self->deparse($ary->first->sibling->sibling, 9);
1718 $ary = $self->deparse($ary, 1);
1721 if ($enter->flags & OPf_SPECIAL) { # thread special var
1722 $var = $self->pp_threadsv($enter, 1);
1723 } else { # regular my() variable
1724 $var = $self->pp_padsv($enter, 1);
1725 if ($self->padname_sv($enter->targ)->IVX ==
1726 $kid->first->first->sibling->last->cop_seq)
1728 # If the scope of this variable closes at the last
1729 # statement of the loop, it must have been
1731 $var = "my " . $var;
1734 } elsif ($var->name eq "rv2gv") {
1735 $var = $self->pp_rv2sv($var, 1);
1736 } elsif ($var->name eq "gv") {
1737 $var = "\$" . $self->deparse($var, 1);
1739 $head = "foreach $var ($ary) ";
1740 $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1741 } elsif ($kid->name eq "null") { # while/until
1743 my $name = {"and" => "while", "or" => "until"}
1745 $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
1746 $kid = $kid->first->sibling;
1747 } elsif ($kid->name eq "stub") { # bare and empty
1748 return "{;}"; # {} could be a hashref
1750 # The third-to-last kid is the continue block if the pointer used
1751 # by `next BLOCK' points to its first OP, which happens to be the
1752 # the op_next of the head of the _previous_ statement.
1753 # Unless it's a bare loop, in which case it's last, since there's
1754 # no unstack or extra nextstate.
1755 # Except if the previous head isn't null but the first kid is
1756 # (because it's a nulled out nextstate in a scope), in which
1757 # case the head's next is advanced past the null but the nextop's
1758 # isn't, so we need to try nextop->next.
1760 my $cont = $kid->first;
1762 while (!null($cont->sibling)) {
1764 $cont = $cont->sibling;
1767 while (!null($cont->sibling->sibling->sibling)) {
1769 $cont = $cont->sibling;
1772 if ($precont and $ {$precont->next} == $ {$enter->nextop}
1773 || $ {$precont->next} == $ {$enter->nextop->next} )
1775 my $state = $kid->first;
1776 my $cuddle = $self->{'cuddle'};
1778 for (; $$state != $$cont; $state = $state->sibling) {
1780 if (is_state $state) {
1781 $expr = $self->deparse($state, 0);
1782 $state = $state->sibling;
1785 $expr .= $self->deparse($state, 0);
1786 push @exprs, $expr if $expr;
1788 $kid = join(";\n", @exprs);
1789 $cont = $cuddle . "continue {\n\t" .
1790 $self->deparse($cont, 0) . "\n\b}\cK";
1793 $kid = $self->deparse($kid, 0);
1795 return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1800 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
1803 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
1804 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
1809 if (class($op) eq "OP") {
1811 return $self->{'ex_const'} if $op->targ == OP_CONST;
1812 } elsif ($op->first->name eq "pushmark") {
1813 return $self->pp_list($op, $cx);
1814 } elsif ($op->first->name eq "enter") {
1815 return $self->pp_leave($op, $cx);
1816 } elsif ($op->targ == OP_STRINGIFY) {
1817 return $self->dquote($op);
1818 } elsif (!null($op->first->sibling) and
1819 $op->first->sibling->name eq "readline" and
1820 $op->first->sibling->flags & OPf_STACKED) {
1821 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1822 . $self->deparse($op->first->sibling, 7),
1824 } elsif (!null($op->first->sibling) and
1825 $op->first->sibling->name eq "trans" and
1826 $op->first->sibling->flags & OPf_STACKED) {
1827 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1828 . $self->deparse($op->first->sibling, 20),
1831 return $self->deparse($op->first, $cx);
1835 # the aassign in-common check messes up SvCUR (always setting it
1836 # to a value >= 100), but it's probably safe to assume there
1837 # won't be any NULs in the names of my() variables. (with
1838 # stash variables, I wouldn't be so sure)
1841 $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
1848 my $str = $self->padname_sv($targ)->PV;
1849 return padname_fix($str);
1855 return substr($self->padname($op->targ), 1); # skip $/@/%
1861 return $self->maybe_my($op, $cx, $self->padname($op->targ));
1864 sub pp_padav { pp_padsv(@_) }
1865 sub pp_padhv { pp_padsv(@_) }
1870 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1871 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1872 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1879 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
1886 if ($Config{useithreads}) {
1887 $gv = $self->padval($op->padix);
1898 my $gv = $self->maybe_padgv($op);
1899 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv));
1905 my $gv = $self->maybe_padgv($op);
1906 return $self->gv_name($gv);
1912 my $gv = $self->maybe_padgv($op);
1913 return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1918 my($op, $cx, $type) = @_;
1919 my $kid = $op->first;
1920 my $str = $self->deparse($kid, 0);
1921 return $type . (is_scalar($kid) ? $str : "{$str}");
1924 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1925 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1926 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1932 if ($op->first->name eq "padav") {
1933 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
1935 return $self->maybe_local($op, $cx,
1936 $self->rv2x($op->first, $cx, '$#'));
1940 # skip down to the old, ex-rv2cv
1941 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
1946 my $kid = $op->first;
1947 if ($kid->name eq "const") { # constant list
1948 my $av = $self->const_sv($kid);
1949 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1951 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
1955 sub is_subscriptable {
1957 if ($op->name =~ /^[ahg]elem/) {
1959 } elsif ($op->name eq "entersub") {
1960 my $kid = $op->first;
1961 return 0 unless null $kid->sibling;
1963 $kid = $kid->sibling until null $kid->sibling;
1964 return 0 if is_scope($kid);
1966 return 0 if $kid->name eq "gv";
1967 return 0 if is_scalar($kid);
1968 return is_subscriptable($kid);
1976 my ($op, $cx, $left, $right, $padname) = @_;
1977 my($array, $idx) = ($op->first, $op->first->sibling);
1978 unless ($array->name eq $padname) { # Maybe this has been fixed
1979 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1981 if ($array->name eq $padname) {
1982 $array = $self->padany($array);
1983 } elsif (is_scope($array)) { # ${expr}[0]
1984 $array = "{" . $self->deparse($array, 0) . "}";
1985 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
1986 $array = $self->deparse($array, 24);
1988 # $x[20][3]{hi} or expr->[20]
1989 my $arrow = is_subscriptable($array) ? "" : "->";
1990 return $self->deparse($array, 24) . $arrow .
1991 $left . $self->deparse($idx, 1) . $right;
1993 $idx = $self->deparse($idx, 1);
1994 return "\$" . $array . $left . $idx . $right;
1997 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
1998 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2003 my($glob, $part) = ($op->first, $op->last);
2004 $glob = $glob->first; # skip rv2gv
2005 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2006 my $scope = is_scope($glob);
2007 $glob = $self->deparse($glob, 0);
2008 $part = $self->deparse($part, 1);
2009 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2014 my ($op, $cx, $left, $right, $regname, $padname) = @_;
2016 my(@elems, $kid, $array, $list);
2017 if (class($op) eq "LISTOP") {
2019 } else { # ex-hslice inside delete()
2020 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2024 $array = $array->first
2025 if $array->name eq $regname or $array->name eq "null";
2026 if (is_scope($array)) {
2027 $array = "{" . $self->deparse($array, 0) . "}";
2028 } elsif ($array->name eq $padname) {
2029 $array = $self->padany($array);
2031 $array = $self->deparse($array, 24);
2033 $kid = $op->first->sibling; # skip pushmark
2034 if ($kid->name eq "list") {
2035 $kid = $kid->first->sibling; # skip list, pushmark
2036 for (; !null $kid; $kid = $kid->sibling) {
2037 push @elems, $self->deparse($kid, 6);
2039 $list = join(", ", @elems);
2041 $list = $self->deparse($kid, 1);
2043 return "\@" . $array . $left . $list . $right;
2046 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2047 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2052 my $idx = $op->first;
2053 my $list = $op->last;
2055 $list = $self->deparse($list, 1);
2056 $idx = $self->deparse($idx, 1);
2057 return "($list)" . "[$idx]";
2062 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2067 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2073 my $kid = $op->first->sibling; # skip pushmark
2074 my($meth, $obj, @exprs);
2075 if ($kid->name eq "list" and want_list $kid) {
2076 # When an indirect object isn't a bareword but the args are in
2077 # parens, the parens aren't part of the method syntax (the LLAFR
2078 # doesn't apply), but they make a list with OPf_PARENS set that
2079 # doesn't get flattened by the append_elem that adds the method,
2080 # making a (object, arg1, arg2, ...) list where the object
2081 # usually is. This can be distinguished from
2082 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2083 # object) because in the later the list is in scalar context
2084 # as the left side of -> always is, while in the former
2085 # the list is in list context as method arguments always are.
2086 # (Good thing there aren't method prototypes!)
2087 $meth = $kid->sibling;
2088 $kid = $kid->first->sibling; # skip pushmark
2090 $kid = $kid->sibling;
2091 for (; not null $kid; $kid = $kid->sibling) {
2092 push @exprs, $self->deparse($kid, 6);
2096 $kid = $kid->sibling;
2097 for (; not null $kid->sibling; $kid = $kid->sibling) {
2098 push @exprs, $self->deparse($kid, 6);
2102 $obj = $self->deparse($obj, 24);
2103 if ($meth->name eq "method_named") {
2104 $meth = $self->const_sv($meth)->PV;
2106 $meth = $meth->first;
2107 if ($meth->name eq "const") {
2108 # As of 5.005_58, this case is probably obsoleted by the
2109 # method_named case above
2110 $meth = $self->const_sv($meth)->PV; # needs to be bare
2112 $meth = $self->deparse($meth, 1);
2115 my $args = join(", ", @exprs);
2116 $kid = $obj . "->" . $meth;
2118 return $kid . "(" . $args . ")"; # parens mandatory
2124 # returns "&" if the prototype doesn't match the args,
2125 # or ("", $args_after_prototype_demunging) if it does.
2128 my($proto, @args) = @_;
2132 # An unbackslashed @ or % gobbles up the rest of the args
2133 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2135 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2138 return "&" if @args;
2139 } elsif ($chr eq ";") {
2141 } elsif ($chr eq "@" or $chr eq "%") {
2142 push @reals, map($self->deparse($_, 6), @args);
2148 if (want_scalar $arg) {
2149 push @reals, $self->deparse($arg, 6);
2153 } elsif ($chr eq "&") {
2154 if ($arg->name =~ /^(s?refgen|undef)$/) {
2155 push @reals, $self->deparse($arg, 6);
2159 } elsif ($chr eq "*") {
2160 if ($arg->name =~ /^s?refgen$/
2161 and $arg->first->first->name eq "rv2gv")
2163 $real = $arg->first->first; # skip refgen, null
2164 if ($real->first->name eq "gv") {
2165 push @reals, $self->deparse($real, 6);
2167 push @reals, $self->deparse($real->first, 6);
2172 } elsif (substr($chr, 0, 1) eq "\\") {
2173 $chr = substr($chr, 1);
2174 if ($arg->name =~ /^s?refgen$/ and
2175 !null($real = $arg->first) and
2176 ($chr eq "\$" && is_scalar($real->first)
2178 && $real->first->sibling->name
2181 && $real->first->sibling->name
2183 #or ($chr eq "&" # This doesn't work
2184 # && $real->first->name eq "rv2cv")
2186 && $real->first->name eq "rv2gv")))
2188 push @reals, $self->deparse($real, 6);
2195 return "&" if $proto and !$doneok; # too few args and no `;'
2196 return "&" if @args; # too many args
2197 return ("", join ", ", @reals);
2203 return $self->method($op, $cx) unless null $op->first->sibling;
2207 if ($op->flags & OPf_SPECIAL) {
2209 } elsif ($op->private & OPpENTERSUB_AMPER) {
2213 $kid = $kid->first->sibling; # skip ex-list, pushmark
2214 for (; not null $kid->sibling; $kid = $kid->sibling) {
2219 if (is_scope($kid)) {
2221 $kid = "{" . $self->deparse($kid, 0) . "}";
2222 } elsif ($kid->first->name eq "gv") {
2223 my $gv = $self->maybe_padgv($kid->first);
2224 if (class($gv->CV) ne "SPECIAL") {
2225 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2227 $simple = 1; # only calls of named functions can be prototyped
2228 $kid = $self->deparse($kid, 24);
2229 } elsif (is_scalar $kid->first) {
2231 $kid = $self->deparse($kid, 24);
2234 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2235 $kid = $self->deparse($kid, 24) . $arrow;
2238 if (defined $proto and not $amper) {
2239 ($amper, $args) = $self->check_proto($proto, @exprs);
2240 if ($amper eq "&") {
2241 $args = join(", ", map($self->deparse($_, 6), @exprs));
2244 $args = join(", ", map($self->deparse($_, 6), @exprs));
2246 if ($prefix or $amper) {
2247 if ($op->flags & OPf_STACKED) {
2248 return $prefix . $amper . $kid . "(" . $args . ")";
2250 return $prefix . $amper. $kid;
2253 if (defined $proto and $proto eq "") {
2255 } elsif ($proto eq "\$") {
2256 return $self->maybe_parens_func($kid, $args, $cx, 16);
2257 } elsif ($proto or $simple) {
2258 return $self->maybe_parens_func($kid, $args, $cx, 5);
2260 return "$kid(" . $args . ")";
2265 sub pp_enterwrite { unop(@_, "write") }
2267 # escape things that cause interpolation in double quotes,
2268 # but not character escapes
2271 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2275 # the same, but treat $|, $), and $ at the end of the string differently
2278 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2279 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2283 # character escapes, but not delimiters that might need to be escaped
2284 sub escape_str { # ASCII
2287 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2293 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2294 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2298 # Don't do this for regexen
2301 $str =~ s/\\/\\\\/g;
2305 sub balanced_delim {
2307 my @str = split //, $str;
2308 my($ar, $open, $close, $fail, $c, $cnt);
2309 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2310 ($open, $close) = @$ar;
2311 $fail = 0; $cnt = 0;
2315 } elsif ($c eq $close) {
2324 $fail = 1 if $cnt != 0;
2325 return ($open, "$open$str$close") if not $fail;
2331 my($q, $default, $str) = @_;
2332 return "$default$str$default" if $default and index($str, $default) == -1;
2333 my($succeed, $delim);
2334 ($succeed, $str) = balanced_delim($str);
2335 return "$q$str" if $succeed;
2336 for $delim ('/', '"', '#') {
2337 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2340 $str =~ s/$default/\\$default/g;
2341 return "$default$str$default";
2350 if (class($sv) eq "SPECIAL") {
2351 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2352 } elsif ($sv->FLAGS & SVf_IOK) {
2354 } elsif ($sv->FLAGS & SVf_NOK) {
2356 } elsif ($sv->FLAGS & SVf_ROK) {
2357 return "\\(" . const($sv->RV) . ")"; # constant folded
2360 if ($str =~ /[^ -~]/) { # ASCII for non-printing
2361 return single_delim("qq", '"', uninterp escape_str unback $str);
2363 return single_delim("q", "'", unback $str);
2372 # the constant could be in the pad (under useithreads)
2373 $sv = $self->padval($op->targ) unless $$sv;
2380 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2381 # return $self->const_sv($op)->PV;
2383 my $sv = $self->const_sv($op);
2390 my $type = $op->name;
2391 if ($type eq "const") {
2392 return uninterp(escape_str(unback($self->const_sv($op)->PV)));
2393 } elsif ($type eq "concat") {
2394 return $self->dq($op->first) . $self->dq($op->last);
2395 } elsif ($type eq "uc") {
2396 return '\U' . $self->dq($op->first->sibling) . '\E';
2397 } elsif ($type eq "lc") {
2398 return '\L' . $self->dq($op->first->sibling) . '\E';
2399 } elsif ($type eq "ucfirst") {
2400 return '\u' . $self->dq($op->first->sibling);
2401 } elsif ($type eq "lcfirst") {
2402 return '\l' . $self->dq($op->first->sibling);
2403 } elsif ($type eq "quotemeta") {
2404 return '\Q' . $self->dq($op->first->sibling) . '\E';
2405 } elsif ($type eq "join") {
2406 return $self->deparse($op->last, 26); # was join($", @ary)
2408 return $self->deparse($op, 26);
2416 return single_delim("qx", '`', $self->dq($op->first->sibling));
2421 my($op, $cx) = shift;
2422 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2423 return $self->deparse($kid, $cx) if $self->{'unquote'};
2424 $self->maybe_targmy($kid, $cx,
2425 sub {single_delim("qq", '"', $self->dq($_[1]))});
2428 # OP_STRINGIFY is a listop, but it only ever has one arg
2429 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2431 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2432 # note that tr(from)/to/ is OK, but not tr/from/(to)
2434 my($from, $to) = @_;
2435 my($succeed, $delim);
2436 if ($from !~ m[/] and $to !~ m[/]) {
2437 return "/$from/$to/";
2438 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2439 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2442 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2443 return "$from$delim$to$delim" if index($to, $delim) == -1;
2446 return "$from/$to/";
2449 for $delim ('/', '"', '#') { # note no '
2450 return "$delim$from$delim$to$delim"
2451 if index($to . $from, $delim) == -1;
2453 $from =~ s[/][\\/]g;
2455 return "/$from/$to/";
2461 if ($n == ord '\\') {
2463 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2465 } elsif ($n == ord "\a") {
2467 } elsif ($n == ord "\b") {
2469 } elsif ($n == ord "\t") {
2471 } elsif ($n == ord "\n") {
2473 } elsif ($n == ord "\e") {
2475 } elsif ($n == ord "\f") {
2477 } elsif ($n == ord "\r") {
2479 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2480 return '\\c' . chr(ord("@") + $n);
2482 # return '\x' . sprintf("%02x", $n);
2483 return '\\' . sprintf("%03o", $n);
2490 for ($c = 0; $c < @chars; $c++) {
2493 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2494 $chars[$c + 2] == $tr + 2)
2496 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
2499 $str .= pchr($chars[$c]);
2505 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
2508 sub tr_decode_byte {
2509 my($table, $flags) = @_;
2510 my(@table) = unpack("s256", $table);
2511 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2512 if ($table[ord "-"] != -1 and
2513 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2515 $tr = $table[ord "-"];
2516 $table[ord "-"] = -1;
2520 } else { # -2 ==> delete
2524 for ($c = 0; $c < 256; $c++) {
2527 push @from, $c; push @to, $tr;
2528 } elsif ($tr == -2) {
2532 @from = (@from, @delfrom);
2533 if ($flags & OPpTRANS_COMPLEMENT) {
2536 @from{@from} = (1) x @from;
2537 for ($c = 0; $c < 256; $c++) {
2538 push @newfrom, $c unless $from{$c};
2542 unless ($flags & OPpTRANS_DELETE) {
2543 pop @to while $#to and $to[$#to] == $to[$#to -1];
2546 $from = collapse(@from);
2547 $to = collapse(@to);
2548 $from .= "-" if $delhyphen;
2549 return ($from, $to);
2554 if ($x == ord "-") {
2561 # XXX This doesn't yet handle all cases correctly either
2563 sub tr_decode_utf8 {
2564 my($swash_hv, $flags) = @_;
2565 my %swash = $swash_hv->ARRAY;
2567 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
2568 my $none = $swash{"NONE"}->IV;
2569 my $extra = $none + 1;
2570 my(@from, @delfrom, @to);
2572 foreach $line (split /\n/, $swash{'LIST'}->PV) {
2573 my($min, $max, $result) = split(/\t/, $line);
2580 $result = hex $result;
2581 if ($result == $extra) {
2582 push @delfrom, [$min, $max];
2584 push @from, [$min, $max];
2585 push @to, [$result, $result + $max - $min];
2588 for my $i (0 .. $#from) {
2589 if ($from[$i][0] == ord '-') {
2590 unshift @from, splice(@from, $i, 1);
2591 unshift @to, splice(@to, $i, 1);
2593 } elsif ($from[$i][1] == ord '-') {
2596 unshift @from, ord '-';
2597 unshift @to, ord '-';
2601 for my $i (0 .. $#delfrom) {
2602 if ($delfrom[$i][0] == ord '-') {
2603 push @delfrom, splice(@delfrom, $i, 1);
2605 } elsif ($delfrom[$i][1] == ord '-') {
2607 push @delfrom, ord '-';
2611 if (defined $final and $to[$#to][1] != $final) {
2612 push @to, [$final, $final];
2614 push @from, @delfrom;
2615 if ($flags & OPpTRANS_COMPLEMENT) {
2618 for my $i (0 .. $#from) {
2619 push @newfrom, [$next, $from[$i][0] - 1];
2620 $next = $from[$i][1] + 1;
2623 for my $range (@newfrom) {
2624 if ($range->[0] <= $range->[1]) {
2629 my($from, $to, $diff);
2630 for my $chunk (@from) {
2631 $diff = $chunk->[1] - $chunk->[0];
2633 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2634 } elsif ($diff == 1) {
2635 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2637 $from .= tr_chr($chunk->[0]);
2640 for my $chunk (@to) {
2641 $diff = $chunk->[1] - $chunk->[0];
2643 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2644 } elsif ($diff == 1) {
2645 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2647 $to .= tr_chr($chunk->[0]);
2650 #$final = sprintf("%04x", $final) if defined $final;
2651 #$none = sprintf("%04x", $none) if defined $none;
2652 #$extra = sprintf("%04x", $extra) if defined $extra;
2653 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
2654 #print STDERR $swash{'LIST'}->PV;
2655 return (escape_str($from), escape_str($to));
2662 if (class($op) eq "PVOP") {
2663 ($from, $to) = tr_decode_byte($op->pv, $op->private);
2664 } else { # class($op) eq "SVOP"
2665 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
2668 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
2669 $flags .= "d" if $op->private & OPpTRANS_DELETE;
2670 $to = "" if $from eq $to and $flags eq "";
2671 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2672 return "tr" . double_delim($from, $to) . $flags;
2675 # Like dq(), but different
2679 my $type = $op->name;
2680 if ($type eq "const") {
2681 return uninterp($self->const_sv($op)->PV);
2682 } elsif ($type eq "concat") {
2683 return $self->re_dq($op->first) . $self->re_dq($op->last);
2684 } elsif ($type eq "uc") {
2685 return '\U' . $self->re_dq($op->first->sibling) . '\E';
2686 } elsif ($type eq "lc") {
2687 return '\L' . $self->re_dq($op->first->sibling) . '\E';
2688 } elsif ($type eq "ucfirst") {
2689 return '\u' . $self->re_dq($op->first->sibling);
2690 } elsif ($type eq "lcfirst") {
2691 return '\l' . $self->re_dq($op->first->sibling);
2692 } elsif ($type eq "quotemeta") {
2693 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2694 } elsif ($type eq "join") {
2695 return $self->deparse($op->last, 26); # was join($", @ary)
2697 return $self->deparse($op, 26);
2704 my $kid = $op->first;
2705 $kid = $kid->first if $kid->name eq "regcmaybe";
2706 $kid = $kid->first if $kid->name eq "regcreset";
2707 return $self->re_dq($kid);
2710 # osmic acid -- see osmium tetroxide
2713 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2714 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2715 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2719 my($op, $cx, $name, $delim) = @_;
2720 my $kid = $op->first;
2721 my ($binop, $var, $re) = ("", "", "");
2722 if ($op->flags & OPf_STACKED) {
2724 $var = $self->deparse($kid, 20);
2725 $kid = $kid->sibling;
2728 $re = re_uninterp(escape_str($op->precomp));
2730 $re = $self->deparse($kid, 1);
2733 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2734 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2735 $flags .= "i" if $op->pmflags & PMf_FOLD;
2736 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2737 $flags .= "o" if $op->pmflags & PMf_KEEP;
2738 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2739 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2740 $flags = $matchwords{$flags} if $matchwords{$flags};
2741 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2745 $re = single_delim($name, $delim, $re);
2749 return $self->maybe_parens("$var =~ $re", $cx, 20);
2755 sub pp_match { matchop(@_, "m", "/") }
2756 sub pp_pushre { matchop(@_, "m", "/") }
2757 sub pp_qr { matchop(@_, "qr", "") }
2762 my($kid, @exprs, $ary, $expr);
2764 if ($ {$kid->pmreplroot}) {
2765 $ary = '@' . $self->gv_name($kid->pmreplroot);
2767 for (; !null($kid); $kid = $kid->sibling) {
2768 push @exprs, $self->deparse($kid, 6);
2770 $expr = "split(" . join(", ", @exprs) . ")";
2772 return $self->maybe_parens("$ary = $expr", $cx, 7);
2778 # oxime -- any of various compounds obtained chiefly by the action of
2779 # hydroxylamine on aldehydes and ketones and characterized by the
2780 # bivalent grouping C=NOH [Webster's Tenth]
2783 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2784 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2785 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2786 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2791 my $kid = $op->first;
2792 my($binop, $var, $re, $repl) = ("", "", "", "");
2793 if ($op->flags & OPf_STACKED) {
2795 $var = $self->deparse($kid, 20);
2796 $kid = $kid->sibling;
2799 if (null($op->pmreplroot)) {
2800 $repl = $self->dq($kid);
2801 $kid = $kid->sibling;
2803 $repl = $op->pmreplroot->first; # skip substcont
2804 while ($repl->name eq "entereval") {
2805 $repl = $repl->first;
2808 if ($op->pmflags & PMf_EVAL) {
2809 $repl = $self->deparse($repl, 0);
2811 $repl = $self->dq($repl);
2815 $re = re_uninterp(escape_str($op->precomp));
2817 $re = $self->deparse($kid, 1);
2819 $flags .= "e" if $op->pmflags & PMf_EVAL;
2820 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2821 $flags .= "i" if $op->pmflags & PMf_FOLD;
2822 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2823 $flags .= "o" if $op->pmflags & PMf_KEEP;
2824 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2825 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2826 $flags = $substwords{$flags} if $substwords{$flags};
2828 return $self->maybe_parens("$var =~ s"
2829 . double_delim($re, $repl) . $flags,
2832 return "s". double_delim($re, $repl) . $flags;
2841 B::Deparse - Perl compiler backend to produce perl code
2845 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>][B<,-s>I<LETTERS>]
2850 B::Deparse is a backend module for the Perl compiler that generates
2851 perl source code, based on the internal compiled structure that perl
2852 itself creates after parsing a program. The output of B::Deparse won't
2853 be exactly the same as the original source, since perl doesn't keep
2854 track of comments or whitespace, and there isn't a one-to-one
2855 correspondence between perl's syntactical constructions and their
2856 compiled form, but it will often be close. When you use the B<-p>
2857 option, the output also includes parentheses even when they are not
2858 required by precedence, which can make it easy to see if perl is
2859 parsing your expressions the way you intended.
2861 Please note that this module is mainly new and untested code and is
2862 still under development, so it may change in the future.
2866 As with all compiler backend options, these must follow directly after
2867 the '-MO=Deparse', separated by a comma but not any white space.
2873 Add '#line' declarations to the output based on the line and file
2874 locations of the original code.
2878 Print extra parentheses. Without this option, B::Deparse includes
2879 parentheses in its output only when they are needed, based on the
2880 structure of your program. With B<-p>, it uses parentheses (almost)
2881 whenever they would be legal. This can be useful if you are used to
2882 LISP, or if you want to see how perl parses your input. If you say
2884 if ($var & 0x7f == 65) {print "Gimme an A!"}
2885 print ($which ? $a : $b), "\n";
2886 $name = $ENV{USER} or "Bob";
2888 C<B::Deparse,-p> will print
2891 print('Gimme an A!')
2893 (print(($which ? $a : $b)), '???');
2894 (($name = $ENV{'USER'}) or '???')
2896 which probably isn't what you intended (the C<'???'> is a sign that
2897 perl optimized away a constant value).
2901 Expand double-quoted strings into the corresponding combinations of
2902 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
2905 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
2909 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
2910 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
2912 Note that the expanded form represents the way perl handles such
2913 constructions internally -- this option actually turns off the reverse
2914 translation that B::Deparse usually does. On the other hand, note that
2915 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
2916 of $y into a string before doing the assignment.
2918 =item B<-u>I<PACKAGE>
2920 Normally, B::Deparse deparses the main code of a program, all the subs
2921 called by the main program (and all the subs called by them,
2922 recursively), and any other subs in the main:: package. To include
2923 subs in other packages that aren't called directly, such as AUTOLOAD,
2924 DESTROY, other subs called automatically by perl, and methods (which
2925 aren't resolved to subs until runtime), use the B<-u> option. The
2926 argument to B<-u> is the name of a package, and should follow directly
2927 after the 'u'. Multiple B<-u> options may be given, separated by
2928 commas. Note that unlike some other backends, B::Deparse doesn't
2929 (yet) try to guess automatically when B<-u> is needed -- you must
2932 =item B<-s>I<LETTERS>
2934 Tweak the style of B::Deparse's output. The letters should follow
2935 directly after the 's', with no space or punctuation. The following
2936 options are available:
2942 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2959 The default is not to cuddle.
2963 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
2967 Use tabs for each 8 columns of indent. The default is to use only spaces.
2968 For instance, if the style options are B<-si4T>, a line that's indented
2969 3 times will be preceded by one tab and four spaces; if the options were
2970 B<-si8T>, the same line would be preceded by three tabs.
2972 =item B<v>I<STRING>B<.>
2974 Print I<STRING> for the value of a constant that can't be determined
2975 because it was optimized away (mnemonic: this happens when a constant
2976 is used in B<v>oid context). The end of the string is marked by a period.
2977 The string should be a valid perl expression, generally a constant.
2978 Note that unless it's a number, it probably needs to be quoted, and on
2979 a command line quotes need to be protected from the shell. Some
2980 conventional values include 0, 1, 42, '', 'foo', and
2981 'Useless use of constant omitted' (which may need to be
2982 B<-sv"'Useless use of constant omitted'.">
2983 or something similar depending on your shell). The default is '???'.
2984 If you're using B::Deparse on a module or other file that's require'd,
2985 you shouldn't use a value that evaluates to false, since the customary
2986 true constant at the end of a module will be in void context when the
2987 file is compiled as a main program.
2993 =head1 USING B::Deparse AS A MODULE
2998 $deparse = B::Deparse->new("-p", "-sC");
2999 $body = $deparse->coderef2text(\&func);
3000 eval "sub func $body"; # the inverse operation
3004 B::Deparse can also be used on a sub-by-sub basis from other perl
3009 $deparse = B::Deparse->new(OPTIONS)
3011 Create an object to store the state of a deparsing operation and any
3012 options. The options are the same as those that can be given on the
3013 command line (see L</OPTIONS>); options that are separated by commas
3014 after B<-MO=Deparse> should be given as separate strings. Some
3015 options, like B<-u>, don't make sense for a single subroutine, so
3020 $body = $deparse->coderef2text(\&func)
3021 $body = $deparse->coderef2text(sub ($$) { ... })
3023 Return source code for the body of a subroutine (a block, optionally
3024 preceded by a prototype in parens), given a reference to the
3025 sub. Because a subroutine can have no names, or more than one name,
3026 this method doesn't return a complete subroutine definition -- if you
3027 want to eval the result, you should prepend "sub subname ", or "sub "
3028 for an anonymous function constructor. Unless the sub was defined in
3029 the main:: package, the code will include a package declaration.
3033 See the 'to do' list at the beginning of the module file.
3037 Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier
3038 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3039 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3040 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.