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';
11 use B qw(class main_root main_start main_cv svref_2object opnumber
12 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
13 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
14 OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
15 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
16 SVf_IOK SVf_NOK SVf_ROK SVf_POK
17 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
18 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
22 # Changes between 0.50 and 0.51:
23 # - fixed nulled leave with live enter in sort { }
24 # - fixed reference constants (\"str")
25 # - handle empty programs gracefully
26 # - handle infinte loops (for (;;) {}, while (1) {})
27 # - differentiate between `for my $x ...' and `my $x; for $x ...'
28 # - various minor cleanups
29 # - moved globals into an object
30 # - added `-u', like B::C
31 # - package declarations using cop_stash
32 # - subs, formats and code sorted by cop_seq
33 # Changes between 0.51 and 0.52:
34 # - added pp_threadsv (special variables under USE_THREADS)
35 # - added documentation
36 # Changes between 0.52 and 0.53:
37 # - many changes adding precedence contexts and associativity
38 # - added `-p' and `-s' output style options
39 # - various other minor fixes
40 # Changes between 0.53 and 0.54:
41 # - added support for new `for (1..100)' optimization,
43 # Changes between 0.54 and 0.55:
44 # - added support for new qr// construct
45 # - added support for new pp_regcreset OP
46 # Changes between 0.55 and 0.56:
47 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
48 # - fixed $# on non-lexicals broken in last big rewrite
49 # - added temporary fix for change in opcode of OP_STRINGIFY
50 # - fixed problem in 0.54's for() patch in `for (@ary)'
51 # - fixed precedence in conditional of ?:
52 # - tweaked list paren elimination in `my($x) = @_'
53 # - made continue-block detection trickier wrt. null ops
54 # - fixed various prototype problems in pp_entersub
55 # - added support for sub prototypes that never get GVs
56 # - added unquoting for special filehandle first arg in truncate
57 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
58 # - added semicolons at the ends of blocks
59 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
60 # Changes between 0.56 and 0.561:
61 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
62 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
63 # Changes between 0.561 and 0.57:
64 # - stylistic changes to symbolic constant stuff
65 # - handled scope in s///e replacement code
66 # - added unquote option for expanding "" into concats, etc.
67 # - split method and proto parts of pp_entersub into separate functions
68 # - various minor cleanups
70 # - added parens in \&foo (patch by Albert Dvornik)
71 # Changes between 0.57 and 0.58:
72 # - fixed `0' statements that weren't being printed
73 # - added methods for use from other programs
74 # (based on patches from James Duncan and Hugo van der Sanden)
75 # - added -si and -sT to control indenting (also based on a patch from Hugo)
76 # - added -sv to print something else instead of '???'
77 # - preliminary version of utf8 tr/// handling
79 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
80 # - added support for Hugo's new OP_SETSTATE (like nextstate)
81 # Changes between 0.58 and 0.59
82 # - added support for Chip's OP_METHOD_NAMED
83 # - added support for Ilya's OPpTARGET_MY optimization
84 # - elided arrows before `()' subscripts when possible
87 # - finish tr/// changes
88 # - add option for even more parens (generalize \&foo change)
89 # - {} around variables in strings ("${var}letters")
92 # - left/right context
93 # - recognize `use utf8', `use integer', etc
94 # - treat top-level block specially for incremental output
95 # - interpret in high bit chars in string as utf8 \x{...} (when?)
96 # - copy comments (look at real text with $^P?)
97 # - avoid semis in one-statement blocks
98 # - associativity of &&=, ||=, ?:
99 # - ',' => '=>' (auto-unquote?)
100 # - break long lines ("\r" as discretionary break?)
101 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
102 # - more style options: brace style, hex vs. octal, quotes, ...
103 # - print big ints as hex/octal instead of decimal (heuristic?)
104 # - handle `my $x if 0'?
105 # - include values of variables (e.g. set in BEGIN)
106 # - coordinate with Data::Dumper (both directions? see previous)
107 # - version using op_next instead of op_first/sibling?
108 # - avoid string copies (pass arrays, one big join?)
110 # - while{} with one-statement continue => for(; XXX; XXX) {}?
111 # - -uPackage:: descend recursively?
115 # Tests that will always fail:
116 # comp/redef.t -- all (redefinition happens at compile time)
118 # Object fields (were globals):
121 # (local($a), local($b)) and local($a, $b) have the same internal
122 # representation but the short form looks better. We notice we can
123 # use a large-scale local when checking the list, but need to prevent
124 # individual locals too. This hash holds the addresses of OPs that
125 # have already had their local-ness accounted for. The same thing
129 # CV for current sub (or main program) being deparsed
132 # name of the current package for deparsed code
135 # array of [cop_seq, GV, is_format?] for subs and formats we still
139 # as above, but [name, prototype] for subs that never got a GV
141 # subs_done, forms_done:
142 # keys are addresses of GVs for subs and formats we've already
143 # deparsed (or at least put into subs_todo)
148 # cuddle: ` ' or `\n', depending on -sC
153 # A little explanation of how precedence contexts and associativity
156 # deparse() calls each per-op subroutine with an argument $cx (short
157 # for context, but not the same as the cx* in the perl core), which is
158 # a number describing the op's parents in terms of precedence, whether
159 # they're inside an expression or at statement level, etc. (see
160 # chart below). When ops with children call deparse on them, they pass
161 # along their precedence. Fractional values are used to implement
162 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
163 # parentheses hacks. The major disadvantage of this scheme is that
164 # it doesn't know about right sides and left sides, so say if you
165 # assign a listop to a variable, it can't tell it's allowed to leave
166 # the parens off the listop.
169 # 26 [TODO] inside interpolation context ("")
170 # 25 left terms and list operators (leftward)
174 # 21 right ! ~ \ and unary + and -
179 # 16 nonassoc named unary operators
180 # 15 nonassoc < > <= >= lt gt le ge
181 # 14 nonassoc == != <=> eq ne cmp
188 # 7 right = += -= *= etc.
190 # 5 nonassoc list operators (rightward)
194 # 1 statement modifiers
197 # Nonprinting characters with special meaning:
198 # \cS - steal parens (see maybe_parens_unop)
199 # \n - newline and indent
200 # \t - increase indent
201 # \b - decrease indent (`outdent')
202 # \f - flush left (no indent)
203 # \cK - kill following semicolon, if any
207 return class($op) eq "NULL";
212 my($gv, $cv, $is_form) = @_;
214 if (!null($cv->START) and is_state($cv->START)) {
215 $seq = $cv->START->cop_seq;
219 push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
224 my $ent = shift @{$self->{'subs_todo'}};
225 my $name = $self->gv_name($ent->[1]);
227 return "format $name =\n"
228 . $self->deparse_format($ent->[1]->FORM). "\n";
230 return "sub $name " . $self->deparse_sub($ent->[1]->CV);
237 if ($op->flags & OPf_KIDS) {
239 for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
240 walk_tree($kid, $sub);
249 $op = shift if null $op;
250 return if !$op or null $op;
253 if ($op->name eq "gv") {
254 if ($op->next->name eq "entersub") {
255 next if $self->{'subs_done'}{$ {$op->gv}}++;
256 next if class($op->gv->CV) eq "SPECIAL";
257 $self->todo($op->gv, $op->gv->CV, 0);
258 $self->walk_sub($op->gv->CV);
259 } elsif ($op->next->name eq "enterwrite"
260 or ($op->next->name eq "rv2gv"
261 and $op->next->next->name eq "enterwrite")) {
262 next if $self->{'forms_done'}{$ {$op->gv}}++;
263 next if class($op->gv->FORM) eq "SPECIAL";
264 $self->todo($op->gv, $op->gv->FORM, 1);
265 $self->walk_sub($op->gv->FORM);
275 { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
276 if ($pack eq "main") {
279 $pack = $pack . "::";
282 while (($key, $val) = each %stash) {
283 my $class = class($val);
284 if ($class eq "PV") {
286 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
287 } elsif ($class eq "IV") {
289 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
290 } elsif ($class eq "GV") {
291 if (class($val->CV) ne "SPECIAL") {
292 next if $self->{'subs_done'}{$$val}++;
293 $self->todo($val, $val->CV, 0);
294 $self->walk_sub($val->CV);
296 if (class($val->FORM) ne "SPECIAL") {
297 next if $self->{'forms_done'}{$$val}++;
298 $self->todo($val, $val->FORM, 1);
299 $self->walk_sub($val->FORM);
309 foreach $ar (@{$self->{'protos_todo'}}) {
310 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
311 push @ret, "sub " . $ar->[0] . "$proto;\n";
313 delete $self->{'protos_todo'};
321 while (length($opt = substr($opts, 0, 1))) {
323 $self->{'cuddle'} = " ";
324 $opts = substr($opts, 1);
325 } elsif ($opt eq "i") {
326 $opts =~ s/^i(\d+)//;
327 $self->{'indent_size'} = $1;
328 } elsif ($opt eq "T") {
329 $self->{'use_tabs'} = 1;
330 $opts = substr($opts, 1);
331 } elsif ($opt eq "v") {
332 $opts =~ s/^v([^.]*)(.|$)//;
333 $self->{'ex_const'} = $1;
340 my $self = bless {}, $class;
341 $self->{'subs_todo'} = [];
342 $self->{'curstash'} = "main";
343 $self->{'cuddle'} = "\n";
344 $self->{'indent_size'} = 4;
345 $self->{'use_tabs'} = 0;
346 $self->{'ex_const'} = "'???'";
347 while (my $arg = shift @_) {
348 if (substr($arg, 0, 2) eq "-u") {
349 $self->stash_subs(substr($arg, 2));
350 } elsif ($arg eq "-p") {
351 $self->{'parens'} = 1;
352 } elsif ($arg eq "-l") {
353 $self->{'linenums'} = 1;
354 } elsif ($arg eq "-q") {
355 $self->{'unquote'} = 1;
356 } elsif (substr($arg, 0, 2) eq "-s") {
357 $self->style_opts(substr $arg, 2);
366 my $self = B::Deparse->new(@args);
367 $self->stash_subs("main");
368 $self->{'curcv'} = main_cv;
369 $self->walk_sub(main_cv, main_start);
370 print $self->print_protos;
371 @{$self->{'subs_todo'}} =
372 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
373 print $self->indent($self->deparse(main_root, 0)), "\n"
374 unless null main_root;
376 while (scalar(@{$self->{'subs_todo'}})) {
377 push @text, $self->next_todo;
379 print indent(join("", @text)), "\n" if @text;
386 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
387 return $self->indent($self->deparse_sub(svref_2object($sub)));
393 # cluck if class($op) eq "NULL";
394 # return $self->$ {\("pp_" . $op->name)}($op, $cx);
395 my $meth = "pp_" . $op->name;
396 return $self->$meth($op, $cx);
402 my @lines = split(/\n/, $txt);
407 my $cmd = substr($line, 0, 1);
408 if ($cmd eq "\t" or $cmd eq "\b") {
409 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
410 if ($self->{'use_tabs'}) {
411 $leader = "\t" x ($level / 8) . " " x ($level % 8);
413 $leader = " " x $level;
415 $line = substr($line, 1);
417 if (substr($line, 0, 1) eq "\f") {
418 $line = substr($line, 1); # no indent
420 $line = $leader . $line;
424 return join("\n", @lines);
431 if ($cv->FLAGS & SVf_POK) {
432 $proto = "(". $cv->PV . ") ";
434 local($self->{'curcv'}) = $cv;
435 local($self->{'curstash'}) = $self->{'curstash'};
436 if (not null $cv->ROOT) {
438 return $proto . "{\n\t" .
439 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
441 return $proto . "{}\n";
449 local($self->{'curcv'}) = $form;
450 local($self->{'curstash'}) = $self->{'curstash'};
451 my $op = $form->ROOT;
453 $op = $op->first->first; # skip leavewrite, lineseq
454 while (not null $op) {
455 $op = $op->sibling; # skip nextstate
457 $kid = $op->first->sibling; # skip pushmark
458 push @text, $kid->sv->PV;
459 $kid = $kid->sibling;
460 for (; not null $kid; $kid = $kid->sibling) {
461 push @exprs, $self->deparse($kid, 0);
463 push @text, join(", ", @exprs)."\n" if @exprs;
466 return join("", @text) . ".";
471 return $op->name eq "leave" || $op->name eq "scope"
472 || $op->name eq "lineseq"
473 || ($op->name eq "null" && class($op) eq "UNOP"
474 && (is_scope($op->first) || $op->first->name eq "enter"));
478 my $name = $_[0]->name;
479 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
482 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
484 return (!null($op) and null($op->sibling)
485 and $op->name eq "null" and class($op) eq "UNOP"
486 and (($op->first->name =~ /^(and|or)$/
487 and $op->first->first->sibling->name eq "lineseq")
488 or ($op->first->name eq "lineseq"
489 and not null $op->first->first->sibling
490 and $op->first->first->sibling->name eq "unstack")
496 return ($op->name eq "rv2sv" or
497 $op->name eq "padsv" or
498 $op->name eq "gv" or # only in array/hash constructs
499 $op->flags & OPf_KIDS && !null($op->first)
500 && $op->first->name eq "gvsv");
505 my($text, $cx, $prec) = @_;
506 if ($prec < $cx # unary ops nest just fine
507 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
508 or $self->{'parens'})
511 # In a unop, let parent reuse our parens; see maybe_parens_unop
512 $text = "\cS" . $text if $cx == 16;
519 # same as above, but get around the `if it looks like a function' rule
520 sub maybe_parens_unop {
522 my($name, $kid, $cx) = @_;
523 if ($cx > 16 or $self->{'parens'}) {
524 return "$name(" . $self->deparse($kid, 1) . ")";
526 $kid = $self->deparse($kid, 16);
527 if (substr($kid, 0, 1) eq "\cS") {
529 return $name . substr($kid, 1);
530 } elsif (substr($kid, 0, 1) eq "(") {
531 # avoid looks-like-a-function trap with extra parens
532 # (`+' can lead to ambiguities)
533 return "$name(" . $kid . ")";
540 sub maybe_parens_func {
542 my($func, $text, $cx, $prec) = @_;
543 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
544 return "$func($text)";
546 return "$func $text";
552 my($op, $cx, $text) = @_;
553 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
554 return $self->maybe_parens_func("local", $text, $cx, 16);
562 my($op, $cx, $func, @args) = @_;
563 if ($op->private & OPpTARGET_MY) {
564 my $var = $self->padname($op->targ);
565 my $val = $func->($self, $op, 7, @args);
566 return $self->maybe_parens("$var = $val", $cx, 7);
568 return $func->($self, $op, $cx, @args);
575 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
580 my($op, $cx, $text) = @_;
581 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
582 return $self->maybe_parens_func("my", $text, $cx, 16);
588 # The following OPs don't have functions:
590 # pp_padany -- does not exist after parsing
591 # pp_rcatline -- does not exist
593 sub pp_enter { # see also leave
594 cluck "unexpected OP_ENTER";
598 sub pp_pushmark { # see also list
599 cluck "unexpected OP_PUSHMARK";
603 sub pp_leavesub { # see also deparse_sub
604 cluck "unexpected OP_LEAVESUB";
608 sub pp_leavewrite { # see also deparse_format
609 cluck "unexpected OP_LEAVEWRITE";
613 sub pp_method { # see also entersub
614 cluck "unexpected OP_METHOD";
618 sub pp_regcmaybe { # see also regcomp
619 cluck "unexpected OP_REGCMAYBE";
623 sub pp_regcreset { # see also regcomp
624 cluck "unexpected OP_REGCRESET";
628 sub pp_substcont { # see also subst
629 cluck "unexpected OP_SUBSTCONT";
633 sub pp_grepstart { # see also grepwhile
634 cluck "unexpected OP_GREPSTART";
638 sub pp_mapstart { # see also mapwhile
639 cluck "unexpected OP_MAPSTART";
643 sub pp_flip { # see also flop
644 cluck "unexpected OP_FLIP";
648 sub pp_iter { # see also leaveloop
649 cluck "unexpected OP_ITER";
653 sub pp_enteriter { # see also leaveloop
654 cluck "unexpected OP_ENTERITER";
658 sub pp_enterloop { # see also leaveloop
659 cluck "unexpected OP_ENTERLOOP";
663 sub pp_leaveeval { # see also entereval
664 cluck "unexpected OP_LEAVEEVAL";
668 sub pp_entertry { # see also leavetry
669 cluck "unexpected OP_ENTERTRY";
673 # leave and scope/lineseq should probably share code
679 local($self->{'curstash'}) = $self->{'curstash'};
680 $kid = $op->first->sibling; # skip enter
681 if (is_miniwhile($kid)) {
682 my $top = $kid->first;
683 my $name = $top->name;
684 if ($name eq "and") {
686 } elsif ($name eq "or") {
688 } else { # no conditional -> while 1 or until 0
689 return $self->deparse($top->first, 1) . " while 1";
691 my $cond = $top->first;
692 my $body = $cond->sibling->first; # skip lineseq
693 $cond = $self->deparse($cond, 1);
694 $body = $self->deparse($body, 1);
695 return "$body $name $cond";
697 for (; !null($kid); $kid = $kid->sibling) {
700 $expr = $self->deparse($kid, 0);
701 $kid = $kid->sibling;
704 $expr .= $self->deparse($kid, 0);
705 push @exprs, $expr if length $expr;
707 if ($cx > 0) { # inside an expression
708 return "do { " . join(";\n", @exprs) . " }";
710 return join(";\n", @exprs) . ";";
719 for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
722 $expr = $self->deparse($kid, 0);
723 $kid = $kid->sibling;
726 $expr .= $self->deparse($kid, 0);
727 push @exprs, $expr if length $expr;
729 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
730 return "do { " . join(";\n", @exprs) . " }";
732 return join(";\n", @exprs) . ";";
736 sub pp_lineseq { pp_scope(@_) }
738 # The BEGIN {} is used here because otherwise this code isn't executed
739 # when you run B::Deparse on itself.
741 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
742 "ENV", "ARGV", "ARGVOUT", "_"); }
747 my $stash = $gv->STASH->NAME;
748 my $name = $gv->NAME;
749 if ($stash eq $self->{'curstash'} or $globalnames{$name}
750 or $name =~ /^[^A-Za-z_]/)
754 $stash = $stash . "::";
756 if ($name =~ /^([\cA-\cZ])$/) {
757 $name = "^" . chr(64 + ord($1));
759 return $stash . $name;
762 # Notice how subs and formats are inserted between statements here
767 @text = $op->label . ": " if $op->label;
768 my $seq = $op->cop_seq;
769 while (scalar(@{$self->{'subs_todo'}})
770 and $seq > $self->{'subs_todo'}[0][0]) {
771 push @text, $self->next_todo;
773 my $stash = $op->stash->NAME;
774 if ($stash ne $self->{'curstash'}) {
775 push @text, "package $stash;\n";
776 $self->{'curstash'} = $stash;
778 if ($self->{'linenums'}) {
779 push @text, "\f#line " . $op->line .
780 ' "' . substr($op->filegv->NAME, 2), qq'"\n';
782 return join("", @text);
785 sub pp_dbstate { pp_nextstate(@_) }
786 sub pp_setstate { pp_nextstate(@_) }
788 sub pp_unstack { return "" } # see also leaveloop
792 my($op, $cx, $name) = @_;
796 sub pp_stub { baseop(@_, "()") }
797 sub pp_wantarray { baseop(@_, "wantarray") }
798 sub pp_fork { baseop(@_, "fork") }
799 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
800 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
801 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
802 sub pp_tms { baseop(@_, "times") }
803 sub pp_ghostent { baseop(@_, "gethostent") }
804 sub pp_gnetent { baseop(@_, "getnetent") }
805 sub pp_gprotoent { baseop(@_, "getprotoent") }
806 sub pp_gservent { baseop(@_, "getservent") }
807 sub pp_ehostent { baseop(@_, "endhostent") }
808 sub pp_enetent { baseop(@_, "endnetent") }
809 sub pp_eprotoent { baseop(@_, "endprotoent") }
810 sub pp_eservent { baseop(@_, "endservent") }
811 sub pp_gpwent { baseop(@_, "getpwent") }
812 sub pp_spwent { baseop(@_, "setpwent") }
813 sub pp_epwent { baseop(@_, "endpwent") }
814 sub pp_ggrent { baseop(@_, "getgrent") }
815 sub pp_sgrent { baseop(@_, "setgrent") }
816 sub pp_egrent { baseop(@_, "endgrent") }
817 sub pp_getlogin { baseop(@_, "getlogin") }
821 # I couldn't think of a good short name, but this is the category of
822 # symbolic unary operators with interesting precedence
826 my($op, $cx, $name, $prec, $flags) = (@_, 0);
827 my $kid = $op->first;
828 $kid = $self->deparse($kid, $prec);
829 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
833 sub pp_preinc { pfixop(@_, "++", 23) }
834 sub pp_predec { pfixop(@_, "--", 23) }
835 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
836 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
837 sub pp_i_preinc { pfixop(@_, "++", 23) }
838 sub pp_i_predec { pfixop(@_, "--", 23) }
839 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
840 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
841 sub pp_complement { maybe_targmy(@_. \&pfixop, "~", 21) }
843 sub pp_negate { maybe_targmy(@_, \&real_negate) }
847 if ($op->first->name =~ /^(i_)?negate$/) {
849 $self->pfixop($op, $cx, "-", 21.5);
851 $self->pfixop($op, $cx, "-", 21);
854 sub pp_i_negate { pp_negate(@_) }
860 $self->pfixop($op, $cx, "not ", 4);
862 $self->pfixop($op, $cx, "!", 21);
868 my($op, $cx, $name) = @_;
870 if ($op->flags & OPf_KIDS) {
872 return $self->maybe_parens_unop($name, $kid, $cx);
874 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
878 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
879 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
880 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
881 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
882 sub pp_defined { unop(@_, "defined") }
883 sub pp_undef { unop(@_, "undef") }
884 sub pp_study { unop(@_, "study") }
885 sub pp_ref { unop(@_, "ref") }
886 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
888 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
889 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
890 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
891 sub pp_srand { unop(@_, "srand") }
892 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
893 sub pp_log { maybe_targmy(@_, \&unop, "log") }
894 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
895 sub pp_int { maybe_targmy(@_, \&unop, "int") }
896 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
897 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
898 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
900 sub pp_length { maybe_targmy(@_, \&unop, "length") }
901 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
902 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
904 sub pp_each { unop(@_, "each") }
905 sub pp_values { unop(@_, "values") }
906 sub pp_keys { unop(@_, "keys") }
907 sub pp_pop { unop(@_, "pop") }
908 sub pp_shift { unop(@_, "shift") }
910 sub pp_caller { unop(@_, "caller") }
911 sub pp_reset { unop(@_, "reset") }
912 sub pp_exit { unop(@_, "exit") }
913 sub pp_prototype { unop(@_, "prototype") }
915 sub pp_close { unop(@_, "close") }
916 sub pp_fileno { unop(@_, "fileno") }
917 sub pp_umask { unop(@_, "umask") }
918 sub pp_binmode { unop(@_, "binmode") }
919 sub pp_untie { unop(@_, "untie") }
920 sub pp_tied { unop(@_, "tied") }
921 sub pp_dbmclose { unop(@_, "dbmclose") }
922 sub pp_getc { unop(@_, "getc") }
923 sub pp_eof { unop(@_, "eof") }
924 sub pp_tell { unop(@_, "tell") }
925 sub pp_getsockname { unop(@_, "getsockname") }
926 sub pp_getpeername { unop(@_, "getpeername") }
928 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
929 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
930 sub pp_readlink { unop(@_, "readlink") }
931 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
932 sub pp_readdir { unop(@_, "readdir") }
933 sub pp_telldir { unop(@_, "telldir") }
934 sub pp_rewinddir { unop(@_, "rewinddir") }
935 sub pp_closedir { unop(@_, "closedir") }
936 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
937 sub pp_localtime { unop(@_, "localtime") }
938 sub pp_gmtime { unop(@_, "gmtime") }
939 sub pp_alarm { unop(@_, "alarm") }
940 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
942 sub pp_dofile { unop(@_, "do") }
943 sub pp_entereval { unop(@_, "eval") }
945 sub pp_ghbyname { unop(@_, "gethostbyname") }
946 sub pp_gnbyname { unop(@_, "getnetbyname") }
947 sub pp_gpbyname { unop(@_, "getprotobyname") }
948 sub pp_shostent { unop(@_, "sethostent") }
949 sub pp_snetent { unop(@_, "setnetent") }
950 sub pp_sprotoent { unop(@_, "setprotoent") }
951 sub pp_sservent { unop(@_, "setservent") }
952 sub pp_gpwnam { unop(@_, "getpwnam") }
953 sub pp_gpwuid { unop(@_, "getpwuid") }
954 sub pp_ggrnam { unop(@_, "getgrnam") }
955 sub pp_ggrgid { unop(@_, "getgrgid") }
957 sub pp_lock { unop(@_, "lock") }
962 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
970 if ($op->private & OPpSLICE) {
971 return $self->maybe_parens_func("delete",
972 $self->pp_hslice($op->first, 16),
975 return $self->maybe_parens_func("delete",
976 $self->pp_helem($op->first, 16),
984 if (class($op) eq "UNOP" and $op->first->name eq "const"
985 and $op->first->private & OPpCONST_BARE)
987 my $name = $op->first->sv->PV;
990 return "require($name)";
992 $self->unop($op, $cx, "require");
999 my $kid = $op->first;
1000 if (not null $kid->sibling) {
1001 # XXX Was a here-doc
1002 return $self->dquote($op);
1004 $self->unop(@_, "scalar");
1011 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1017 my $kid = $op->first;
1018 if ($kid->name eq "null") {
1020 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1021 my($pre, $post) = @{{"anonlist" => ["[","]"],
1022 "anonhash" => ["{","}"]}->{$kid->name}};
1024 $kid = $kid->first->sibling; # skip pushmark
1025 for (; !null($kid); $kid = $kid->sibling) {
1026 $expr = $self->deparse($kid, 6);
1029 return $pre . join(", ", @exprs) . $post;
1030 } elsif (!null($kid->sibling) and
1031 $kid->sibling->name eq "anoncode") {
1033 $self->deparse_sub($self->padval($kid->sibling->targ));
1034 } elsif ($kid->name eq "pushmark") {
1035 my $sib_name = $kid->sibling->name;
1036 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1037 and not $kid->sibling->flags & OPf_REF)
1039 # The @a in \(@a) isn't in ref context, but only when the
1041 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1042 } elsif ($sib_name eq 'entersub') {
1043 my $text = $self->deparse($kid->sibling, 1);
1044 # Always show parens for \(&func()), but only with -p otherwise
1045 $text = "($text)" if $self->{'parens'}
1046 or $kid->sibling->private & OPpENTERSUB_AMPER;
1051 $self->pfixop($op, $cx, "\\", 20);
1054 sub pp_srefgen { pp_refgen(@_) }
1059 my $kid = $op->first;
1060 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1061 return "<" . $self->deparse($kid, 1) . ">";
1064 # Unary operators that can occur as pseudo-listops inside double quotes
1067 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1069 if ($op->flags & OPf_KIDS) {
1071 # If there's more than one kid, the first is an ex-pushmark.
1072 $kid = $kid->sibling if not null $kid->sibling;
1073 return $self->maybe_parens_unop($name, $kid, $cx);
1075 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1079 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1080 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1081 sub pp_uc { dq_unop(@_, "uc") }
1082 sub pp_lc { dq_unop(@_, "lc") }
1083 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1087 my ($op, $cx, $name) = @_;
1088 if (class($op) eq "PVOP") {
1089 return "$name " . $op->pv;
1090 } elsif (class($op) eq "OP") {
1092 } elsif (class($op) eq "UNOP") {
1093 # Note -- loop exits are actually exempt from the
1094 # looks-like-a-func rule, but a few extra parens won't hurt
1095 return $self->maybe_parens_unop($name, $op->first, $cx);
1099 sub pp_last { loopex(@_, "last") }
1100 sub pp_next { loopex(@_, "next") }
1101 sub pp_redo { loopex(@_, "redo") }
1102 sub pp_goto { loopex(@_, "goto") }
1103 sub pp_dump { loopex(@_, "dump") }
1107 my($op, $cx, $name) = @_;
1108 if (class($op) eq "UNOP") {
1109 # Genuine `-X' filetests are exempt from the LLAFR, but not
1110 # l?stat(); for the sake of clarity, give'em all parens
1111 return $self->maybe_parens_unop($name, $op->first, $cx);
1112 } elsif (class($op) eq "GVOP") {
1113 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1114 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1119 sub pp_lstat { ftst(@_, "lstat") }
1120 sub pp_stat { ftst(@_, "stat") }
1121 sub pp_ftrread { ftst(@_, "-R") }
1122 sub pp_ftrwrite { ftst(@_, "-W") }
1123 sub pp_ftrexec { ftst(@_, "-X") }
1124 sub pp_fteread { ftst(@_, "-r") }
1125 sub pp_ftewrite { ftst(@_, "-r") }
1126 sub pp_fteexec { ftst(@_, "-r") }
1127 sub pp_ftis { ftst(@_, "-e") }
1128 sub pp_fteowned { ftst(@_, "-O") }
1129 sub pp_ftrowned { ftst(@_, "-o") }
1130 sub pp_ftzero { ftst(@_, "-z") }
1131 sub pp_ftsize { ftst(@_, "-s") }
1132 sub pp_ftmtime { ftst(@_, "-M") }
1133 sub pp_ftatime { ftst(@_, "-A") }
1134 sub pp_ftctime { ftst(@_, "-C") }
1135 sub pp_ftsock { ftst(@_, "-S") }
1136 sub pp_ftchr { ftst(@_, "-c") }
1137 sub pp_ftblk { ftst(@_, "-b") }
1138 sub pp_ftfile { ftst(@_, "-f") }
1139 sub pp_ftdir { ftst(@_, "-d") }
1140 sub pp_ftpipe { ftst(@_, "-p") }
1141 sub pp_ftlink { ftst(@_, "-l") }
1142 sub pp_ftsuid { ftst(@_, "-u") }
1143 sub pp_ftsgid { ftst(@_, "-g") }
1144 sub pp_ftsvtx { ftst(@_, "-k") }
1145 sub pp_fttty { ftst(@_, "-t") }
1146 sub pp_fttext { ftst(@_, "-T") }
1147 sub pp_ftbinary { ftst(@_, "-B") }
1149 sub SWAP_CHILDREN () { 1 }
1150 sub ASSIGN () { 2 } # has OP= variant
1156 my $name = $op->name;
1157 if ($name eq "concat" and $op->first->name eq "concat") {
1158 # avoid spurious `=' -- see comment in pp_concat
1161 if ($name eq "null" and class($op) eq "UNOP"
1162 and $op->first->name =~ /^(and|x?or)$/
1163 and null $op->first->sibling)
1165 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1166 # with a null that's used as the common end point of the two
1167 # flows of control. For precedence purposes, ignore it.
1168 # (COND_EXPRs have these too, but we don't bother with
1169 # their associativity).
1170 return assoc_class($op->first);
1172 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1175 # Left associative operators, like `+', for which
1176 # $a + $b + $c is equivalent to ($a + $b) + $c
1179 %left = ('multiply' => 19, 'i_multiply' => 19,
1180 'divide' => 19, 'i_divide' => 19,
1181 'modulo' => 19, 'i_modulo' => 19,
1183 'add' => 18, 'i_add' => 18,
1184 'subtract' => 18, 'i_subtract' => 18,
1186 'left_shift' => 17, 'right_shift' => 17,
1188 'bit_or' => 12, 'bit_xor' => 12,
1190 'or' => 2, 'xor' => 2,
1194 sub deparse_binop_left {
1196 my($op, $left, $prec) = @_;
1197 if ($left{assoc_class($op)}
1198 and $left{assoc_class($op)} == $left{assoc_class($left)})
1200 return $self->deparse($left, $prec - .00001);
1202 return $self->deparse($left, $prec);
1206 # Right associative operators, like `=', for which
1207 # $a = $b = $c is equivalent to $a = ($b = $c)
1210 %right = ('pow' => 22,
1211 'sassign=' => 7, 'aassign=' => 7,
1212 'multiply=' => 7, 'i_multiply=' => 7,
1213 'divide=' => 7, 'i_divide=' => 7,
1214 'modulo=' => 7, 'i_modulo=' => 7,
1216 'add=' => 7, 'i_add=' => 7,
1217 'subtract=' => 7, 'i_subtract=' => 7,
1219 'left_shift=' => 7, 'right_shift=' => 7,
1221 'bit_or=' => 7, 'bit_xor=' => 7,
1227 sub deparse_binop_right {
1229 my($op, $right, $prec) = @_;
1230 if ($right{assoc_class($op)}
1231 and $right{assoc_class($op)} == $right{assoc_class($right)})
1233 return $self->deparse($right, $prec - .00001);
1235 return $self->deparse($right, $prec);
1241 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1242 my $left = $op->first;
1243 my $right = $op->last;
1245 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1249 if ($flags & SWAP_CHILDREN) {
1250 ($left, $right) = ($right, $left);
1252 $left = $self->deparse_binop_left($op, $left, $prec);
1253 $right = $self->deparse_binop_right($op, $right, $prec);
1254 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1257 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1258 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1259 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1260 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1261 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1262 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1263 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1264 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1265 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1266 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1267 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1269 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1270 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1271 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1272 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1273 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1275 sub pp_eq { binop(@_, "==", 14) }
1276 sub pp_ne { binop(@_, "!=", 14) }
1277 sub pp_lt { binop(@_, "<", 15) }
1278 sub pp_gt { binop(@_, ">", 15) }
1279 sub pp_ge { binop(@_, ">=", 15) }
1280 sub pp_le { binop(@_, "<=", 15) }
1281 sub pp_ncmp { binop(@_, "<=>", 14) }
1282 sub pp_i_eq { binop(@_, "==", 14) }
1283 sub pp_i_ne { binop(@_, "!=", 14) }
1284 sub pp_i_lt { binop(@_, "<", 15) }
1285 sub pp_i_gt { binop(@_, ">", 15) }
1286 sub pp_i_ge { binop(@_, ">=", 15) }
1287 sub pp_i_le { binop(@_, "<=", 15) }
1288 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1290 sub pp_seq { binop(@_, "eq", 14) }
1291 sub pp_sne { binop(@_, "ne", 14) }
1292 sub pp_slt { binop(@_, "lt", 15) }
1293 sub pp_sgt { binop(@_, "gt", 15) }
1294 sub pp_sge { binop(@_, "ge", 15) }
1295 sub pp_sle { binop(@_, "le", 15) }
1296 sub pp_scmp { binop(@_, "cmp", 14) }
1298 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1299 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1301 # `.' is special because concats-of-concats are optimized to save copying
1302 # by making all but the first concat stacked. The effect is as if the
1303 # programmer had written `($a . $b) .= $c', except legal.
1304 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1308 my $left = $op->first;
1309 my $right = $op->last;
1312 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1316 $left = $self->deparse_binop_left($op, $left, $prec);
1317 $right = $self->deparse_binop_right($op, $right, $prec);
1318 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1321 # `x' is weird when the left arg is a list
1325 my $left = $op->first;
1326 my $right = $op->last;
1329 if ($op->flags & OPf_STACKED) {
1333 if (null($right)) { # list repeat; count is inside left-side ex-list
1334 my $kid = $left->first->sibling; # skip pushmark
1336 for (; !null($kid->sibling); $kid = $kid->sibling) {
1337 push @exprs, $self->deparse($kid, 6);
1340 $left = "(" . join(", ", @exprs). ")";
1342 $left = $self->deparse_binop_left($op, $left, $prec);
1344 $right = $self->deparse_binop_right($op, $right, $prec);
1345 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1350 my ($op, $cx, $type) = @_;
1351 my $left = $op->first;
1352 my $right = $left->sibling;
1353 $left = $self->deparse($left, 9);
1354 $right = $self->deparse($right, 9);
1355 return $self->maybe_parens("$left $type $right", $cx, 9);
1361 my $flip = $op->first;
1362 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1363 return $self->range($flip->first, $cx, $type);
1366 # one-line while/until is handled in pp_leave
1370 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1371 my $left = $op->first;
1372 my $right = $op->first->sibling;
1373 if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
1374 $left = $self->deparse($left, 1);
1375 $right = $self->deparse($right, 0);
1376 return "$blockname ($left) {\n\t$right\n\b}\cK";
1377 } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
1378 $right = $self->deparse($right, 1);
1379 $left = $self->deparse($left, 1);
1380 return "$right $blockname $left";
1381 } elsif ($cx > $lowprec and $highop) { # $a && $b
1382 $left = $self->deparse_binop_left($op, $left, $highprec);
1383 $right = $self->deparse_binop_right($op, $right, $highprec);
1384 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1385 } else { # $a and $b
1386 $left = $self->deparse_binop_left($op, $left, $lowprec);
1387 $right = $self->deparse_binop_right($op, $right, $lowprec);
1388 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1392 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1393 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1395 # xor is syntactically a logop, but it's really a binop (contrary to
1396 # old versions of opcode.pl). Syntax is what matters here.
1397 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1401 my ($op, $cx, $opname) = @_;
1402 my $left = $op->first;
1403 my $right = $op->first->sibling->first; # skip sassign
1404 $left = $self->deparse($left, 7);
1405 $right = $self->deparse($right, 7);
1406 return $self->maybe_parens("$left $opname $right", $cx, 7);
1409 sub pp_andassign { logassignop(@_, "&&=") }
1410 sub pp_orassign { logassignop(@_, "||=") }
1414 my($op, $cx, $name) = @_;
1416 my $parens = ($cx >= 5) || $self->{'parens'};
1417 my $kid = $op->first->sibling;
1418 return $name if null $kid;
1419 my $first = $self->deparse($kid, 6);
1420 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1421 push @exprs, $first;
1422 $kid = $kid->sibling;
1423 for (; !null($kid); $kid = $kid->sibling) {
1424 push @exprs, $self->deparse($kid, 6);
1427 return "$name(" . join(", ", @exprs) . ")";
1429 return "$name " . join(", ", @exprs);
1433 sub pp_bless { listop(@_, "bless") }
1434 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
1435 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1436 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1437 sub pp_index { maybe_targmy(@_, \&listop, "index") }
1438 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
1439 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
1440 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1441 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
1442 sub pp_unpack { listop(@_, "unpack") }
1443 sub pp_pack { listop(@_, "pack") }
1444 sub pp_join { maybe_targmy(@_, \&listop, "join") }
1445 sub pp_splice { listop(@_, "splice") }
1446 sub pp_push { maybe_targmy(@_, \&listop, "push") }
1447 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
1448 sub pp_reverse { listop(@_, "reverse") }
1449 sub pp_warn { listop(@_, "warn") }
1450 sub pp_die { listop(@_, "die") }
1451 # Actually, return is exempt from the LLAFR (see examples in this very
1452 # module!), but for consistency's sake, ignore that fact
1453 sub pp_return { listop(@_, "return") }
1454 sub pp_open { listop(@_, "open") }
1455 sub pp_pipe_op { listop(@_, "pipe") }
1456 sub pp_tie { listop(@_, "tie") }
1457 sub pp_dbmopen { listop(@_, "dbmopen") }
1458 sub pp_sselect { listop(@_, "select") }
1459 sub pp_select { listop(@_, "select") }
1460 sub pp_read { listop(@_, "read") }
1461 sub pp_sysopen { listop(@_, "sysopen") }
1462 sub pp_sysseek { listop(@_, "sysseek") }
1463 sub pp_sysread { listop(@_, "sysread") }
1464 sub pp_syswrite { listop(@_, "syswrite") }
1465 sub pp_send { listop(@_, "send") }
1466 sub pp_recv { listop(@_, "recv") }
1467 sub pp_seek { listop(@_, "seek") }
1468 sub pp_fcntl { listop(@_, "fcntl") }
1469 sub pp_ioctl { listop(@_, "ioctl") }
1470 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
1471 sub pp_socket { listop(@_, "socket") }
1472 sub pp_sockpair { listop(@_, "sockpair") }
1473 sub pp_bind { listop(@_, "bind") }
1474 sub pp_connect { listop(@_, "connect") }
1475 sub pp_listen { listop(@_, "listen") }
1476 sub pp_accept { listop(@_, "accept") }
1477 sub pp_shutdown { listop(@_, "shutdown") }
1478 sub pp_gsockopt { listop(@_, "getsockopt") }
1479 sub pp_ssockopt { listop(@_, "setsockopt") }
1480 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
1481 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
1482 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
1483 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
1484 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
1485 sub pp_link { maybe_targmy(@_, \&listop, "link") }
1486 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
1487 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
1488 sub pp_open_dir { listop(@_, "opendir") }
1489 sub pp_seekdir { listop(@_, "seekdir") }
1490 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
1491 sub pp_system { maybe_targmy(@_, \&listop, "system") }
1492 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
1493 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
1494 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
1495 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
1496 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
1497 sub pp_shmget { listop(@_, "shmget") }
1498 sub pp_shmctl { listop(@_, "shmctl") }
1499 sub pp_shmread { listop(@_, "shmread") }
1500 sub pp_shmwrite { listop(@_, "shmwrite") }
1501 sub pp_msgget { listop(@_, "msgget") }
1502 sub pp_msgctl { listop(@_, "msgctl") }
1503 sub pp_msgsnd { listop(@_, "msgsnd") }
1504 sub pp_msgrcv { listop(@_, "msgrcv") }
1505 sub pp_semget { listop(@_, "semget") }
1506 sub pp_semctl { listop(@_, "semctl") }
1507 sub pp_semop { listop(@_, "semop") }
1508 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1509 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1510 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1511 sub pp_gsbyname { listop(@_, "getservbyname") }
1512 sub pp_gsbyport { listop(@_, "getservbyport") }
1513 sub pp_syscall { listop(@_, "syscall") }
1518 my $text = $self->dq($op->first->sibling); # skip pushmark
1519 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1520 or $text =~ /[<>]/) {
1521 return 'glob(' . single_delim('qq', '"', $text) . ')';
1523 return '<' . $text . '>';
1527 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1528 # be a filehandle. This could probably be better fixed in the core
1529 # by moving the GV lookup into ck_truc.
1535 my $parens = ($cx >= 5) || $self->{'parens'};
1536 my $kid = $op->first->sibling;
1538 if ($op->flags & OPf_SPECIAL) {
1539 # $kid is an OP_CONST
1542 $fh = $self->deparse($kid, 6);
1543 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1545 my $len = $self->deparse($kid->sibling, 6);
1547 return "truncate($fh, $len)";
1549 return "truncate $fh, $len";
1555 my($op, $cx, $name) = @_;
1557 my $kid = $op->first->sibling;
1559 if ($op->flags & OPf_STACKED) {
1561 $indir = $indir->first; # skip rv2gv
1562 if (is_scope($indir)) {
1563 $indir = "{" . $self->deparse($indir, 0) . "}";
1565 $indir = $self->deparse($indir, 24);
1567 $indir = $indir . " ";
1568 $kid = $kid->sibling;
1570 for (; !null($kid); $kid = $kid->sibling) {
1571 $expr = $self->deparse($kid, 6);
1574 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
1578 sub pp_prtf { indirop(@_, "printf") }
1579 sub pp_print { indirop(@_, "print") }
1580 sub pp_sort { indirop(@_, "sort") }
1584 my($op, $cx, $name) = @_;
1586 my $kid = $op->first; # this is the (map|grep)start
1587 $kid = $kid->first->sibling; # skip a pushmark
1588 my $code = $kid->first; # skip a null
1589 if (is_scope $code) {
1590 $code = "{" . $self->deparse($code, 0) . "} ";
1592 $code = $self->deparse($code, 24) . ", ";
1594 $kid = $kid->sibling;
1595 for (; !null($kid); $kid = $kid->sibling) {
1596 $expr = $self->deparse($kid, 6);
1597 push @exprs, $expr if $expr;
1599 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1602 sub pp_mapwhile { mapop(@_, "map") }
1603 sub pp_grepwhile { mapop(@_, "grep") }
1609 my $kid = $op->first->sibling; # skip pushmark
1611 my $local = "either"; # could be local(...) or my(...)
1612 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1613 # This assumes that no other private flags equal 128, and that
1614 # OPs that store things other than flags in their op_private,
1615 # like OP_AELEMFAST, won't be immediate children of a list.
1616 unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
1618 $local = ""; # or not
1621 if ($lop->name =~ /^pad[ash]v$/) { # my()
1622 ($local = "", last) if $local eq "local";
1624 } elsif ($lop->name ne "undef") { # local()
1625 ($local = "", last) if $local eq "my";
1629 $local = "" if $local eq "either"; # no point if it's all undefs
1630 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
1631 for (; !null($kid); $kid = $kid->sibling) {
1633 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
1638 $self->{'avoid_local'}{$$lop}++;
1639 $expr = $self->deparse($kid, 6);
1640 delete $self->{'avoid_local'}{$$lop};
1642 $expr = $self->deparse($kid, 6);
1647 return "$local(" . join(", ", @exprs) . ")";
1649 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1656 my $cond = $op->first;
1657 my $true = $cond->sibling;
1658 my $false = $true->sibling;
1659 my $cuddle = $self->{'cuddle'};
1660 unless ($cx == 0 and is_scope($true) and is_scope($false)) {
1661 $cond = $self->deparse($cond, 8);
1662 $true = $self->deparse($true, 8);
1663 $false = $self->deparse($false, 8);
1664 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1666 $cond = $self->deparse($cond, 1);
1667 $true = $self->deparse($true, 0);
1668 if ($false->name eq "lineseq") { # braces w/o scope => elsif
1669 my $head = "if ($cond) {\n\t$true\n\b}";
1671 while (!null($false) and $false->name eq "lineseq") {
1672 my $newop = $false->first->sibling->first;
1673 my $newcond = $newop->first;
1674 my $newtrue = $newcond->sibling;
1675 $false = $newtrue->sibling; # last in chain is OP_AND => no else
1676 $newcond = $self->deparse($newcond, 1);
1677 $newtrue = $self->deparse($newtrue, 0);
1678 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1680 if (!null($false)) {
1681 $false = $cuddle . "else {\n\t" .
1682 $self->deparse($false, 0) . "\n\b}\cK";
1686 return $head . join($cuddle, "", @elsifs) . $false;
1688 $false = $self->deparse($false, 0);
1689 return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK";
1695 my $enter = $op->first;
1696 my $kid = $enter->sibling;
1697 local($self->{'curstash'}) = $self->{'curstash'};
1700 if ($kid->name eq "lineseq") { # bare or infinite loop
1701 if (is_state $kid->last) { # infinite
1702 $head = "for (;;) "; # shorter than while (1)
1706 } elsif ($enter->name eq "enteriter") { # foreach
1707 my $ary = $enter->first->sibling; # first was pushmark
1708 my $var = $ary->sibling;
1709 if ($enter->flags & OPf_STACKED
1710 and not null $ary->first->sibling->sibling)
1712 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1713 $self->deparse($ary->first->sibling->sibling, 9);
1715 $ary = $self->deparse($ary, 1);
1718 if ($enter->flags & OPf_SPECIAL) { # thread special var
1719 $var = $self->pp_threadsv($enter, 1);
1720 } else { # regular my() variable
1721 $var = $self->pp_padsv($enter, 1);
1722 if ($self->padname_sv($enter->targ)->IVX ==
1723 $kid->first->first->sibling->last->cop_seq)
1725 # If the scope of this variable closes at the last
1726 # statement of the loop, it must have been
1728 $var = "my " . $var;
1731 } elsif ($var->name eq "rv2gv") {
1732 $var = $self->pp_rv2sv($var, 1);
1733 } elsif ($var->name eq "gv") {
1734 $var = "\$" . $self->deparse($var, 1);
1736 $head = "foreach $var ($ary) ";
1737 $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1738 } elsif ($kid->name eq "null") { # while/until
1740 my $name = {"and" => "while", "or" => "until"}
1742 $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
1743 $kid = $kid->first->sibling;
1744 } elsif ($kid->name eq "stub") { # bare and empty
1745 return "{;}"; # {} could be a hashref
1747 # The third-to-last kid is the continue block if the pointer used
1748 # by `next BLOCK' points to its first OP, which happens to be the
1749 # the op_next of the head of the _previous_ statement.
1750 # Unless it's a bare loop, in which case it's last, since there's
1751 # no unstack or extra nextstate.
1752 # Except if the previous head isn't null but the first kid is
1753 # (because it's a nulled out nextstate in a scope), in which
1754 # case the head's next is advanced past the null but the nextop's
1755 # isn't, so we need to try nextop->next.
1757 my $cont = $kid->first;
1759 while (!null($cont->sibling)) {
1761 $cont = $cont->sibling;
1764 while (!null($cont->sibling->sibling->sibling)) {
1766 $cont = $cont->sibling;
1769 if ($precont and $ {$precont->next} == $ {$enter->nextop}
1770 || $ {$precont->next} == $ {$enter->nextop->next} )
1772 my $state = $kid->first;
1773 my $cuddle = $self->{'cuddle'};
1775 for (; $$state != $$cont; $state = $state->sibling) {
1777 if (is_state $state) {
1778 $expr = $self->deparse($state, 0);
1779 $state = $state->sibling;
1782 $expr .= $self->deparse($state, 0);
1783 push @exprs, $expr if $expr;
1785 $kid = join(";\n", @exprs);
1786 $cont = $cuddle . "continue {\n\t" .
1787 $self->deparse($cont, 0) . "\n\b}\cK";
1790 $kid = $self->deparse($kid, 0);
1792 return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1797 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
1800 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
1801 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
1806 if (class($op) eq "OP") {
1808 return $self->{'ex_const'} if $op->targ == OP_CONST;
1809 } elsif ($op->first->name eq "pushmark") {
1810 return $self->pp_list($op, $cx);
1811 } elsif ($op->first->name eq "enter") {
1812 return $self->pp_leave($op, $cx);
1813 } elsif ($op->targ == OP_STRINGIFY) {
1814 return $self->dquote($op);
1815 } elsif (!null($op->first->sibling) and
1816 $op->first->sibling->name eq "readline" and
1817 $op->first->sibling->flags & OPf_STACKED) {
1818 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1819 . $self->deparse($op->first->sibling, 7),
1821 } elsif (!null($op->first->sibling) and
1822 $op->first->sibling->name eq "trans" and
1823 $op->first->sibling->flags & OPf_STACKED) {
1824 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1825 . $self->deparse($op->first->sibling, 20),
1828 return $self->deparse($op->first, $cx);
1832 # the aassign in-common check messes up SvCUR (always setting it
1833 # to a value >= 100), but it's probably safe to assume there
1834 # won't be any NULs in the names of my() variables. (with
1835 # stash variables, I wouldn't be so sure)
1838 $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
1845 my $str = $self->padname_sv($targ)->PV;
1846 return padname_fix($str);
1852 return substr($self->padname($op->targ), 1); # skip $/@/%
1858 return $self->maybe_my($op, $cx, $self->padname($op->targ));
1861 sub pp_padav { pp_padsv(@_) }
1862 sub pp_padhv { pp_padsv(@_) }
1867 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1868 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1869 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1876 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
1882 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
1888 return $self->gv_name($op->gv);
1895 return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1900 my($op, $cx, $type) = @_;
1901 my $kid = $op->first;
1902 my $str = $self->deparse($kid, 0);
1903 return $type . (is_scalar($kid) ? $str : "{$str}");
1906 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1907 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1908 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1914 if ($op->first->name eq "padav") {
1915 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
1917 return $self->maybe_local($op, $cx,
1918 $self->rv2x($op->first, $cx, '$#'));
1922 # skip down to the old, ex-rv2cv
1923 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
1928 my $kid = $op->first;
1929 if ($kid->name eq "const") { # constant list
1931 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1933 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
1937 sub is_subscriptable {
1939 if ($op->name =~ /^[ahg]elem/) {
1941 } elsif ($op->name eq "entersub") {
1942 my $kid = $op->first;
1943 return 0 unless null $kid->sibling;
1945 $kid = $kid->sibling until null $kid->sibling;
1946 return 0 if is_scope($kid);
1948 return 0 if $kid->name eq "gv";
1949 return 0 if is_scalar($kid);
1950 return is_subscriptable($kid);
1958 my ($op, $cx, $left, $right, $padname) = @_;
1959 my($array, $idx) = ($op->first, $op->first->sibling);
1960 unless ($array->name eq $padname) { # Maybe this has been fixed
1961 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1963 if ($array->name eq $padname) {
1964 $array = $self->padany($array);
1965 } elsif (is_scope($array)) { # ${expr}[0]
1966 $array = "{" . $self->deparse($array, 0) . "}";
1967 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
1968 $array = $self->deparse($array, 24);
1970 # $x[20][3]{hi} or expr->[20]
1971 my $arrow = is_subscriptable($array) ? "" : "->";
1972 return $self->deparse($array, 24) . $arrow .
1973 $left . $self->deparse($idx, 1) . $right;
1975 $idx = $self->deparse($idx, 1);
1976 return "\$" . $array . $left . $idx . $right;
1979 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
1980 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
1985 my($glob, $part) = ($op->first, $op->last);
1986 $glob = $glob->first; # skip rv2gv
1987 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
1988 my $scope = is_scope($glob);
1989 $glob = $self->deparse($glob, 0);
1990 $part = $self->deparse($part, 1);
1991 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
1996 my ($op, $cx, $left, $right, $regname, $padname) = @_;
1998 my(@elems, $kid, $array, $list);
1999 if (class($op) eq "LISTOP") {
2001 } else { # ex-hslice inside delete()
2002 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2006 $array = $array->first
2007 if $array->name eq $regname or $array->name eq "null";
2008 if (is_scope($array)) {
2009 $array = "{" . $self->deparse($array, 0) . "}";
2010 } elsif ($array->name eq $padname) {
2011 $array = $self->padany($array);
2013 $array = $self->deparse($array, 24);
2015 $kid = $op->first->sibling; # skip pushmark
2016 if ($kid->name eq "list") {
2017 $kid = $kid->first->sibling; # skip list, pushmark
2018 for (; !null $kid; $kid = $kid->sibling) {
2019 push @elems, $self->deparse($kid, 6);
2021 $list = join(", ", @elems);
2023 $list = $self->deparse($kid, 1);
2025 return "\@" . $array . $left . $list . $right;
2028 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2029 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2034 my $idx = $op->first;
2035 my $list = $op->last;
2037 $list = $self->deparse($list, 1);
2038 $idx = $self->deparse($idx, 1);
2039 return "($list)" . "[$idx]";
2044 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2049 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2055 my $kid = $op->first->sibling; # skip pushmark
2056 my($meth, $obj, @exprs);
2057 if ($kid->name eq "list" and want_list $kid) {
2058 # When an indirect object isn't a bareword but the args are in
2059 # parens, the parens aren't part of the method syntax (the LLAFR
2060 # doesn't apply), but they make a list with OPf_PARENS set that
2061 # doesn't get flattened by the append_elem that adds the method,
2062 # making a (object, arg1, arg2, ...) list where the object
2063 # usually is. This can be distinguished from
2064 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2065 # object) because in the later the list is in scalar context
2066 # as the left side of -> always is, while in the former
2067 # the list is in list context as method arguments always are.
2068 # (Good thing there aren't method prototypes!)
2069 $meth = $kid->sibling;
2070 $kid = $kid->first->sibling; # skip pushmark
2072 $kid = $kid->sibling;
2073 for (; not null $kid; $kid = $kid->sibling) {
2074 push @exprs, $self->deparse($kid, 6);
2078 $kid = $kid->sibling;
2079 for (; not null $kid->sibling; $kid = $kid->sibling) {
2080 push @exprs, $self->deparse($kid, 6);
2084 $obj = $self->deparse($obj, 24);
2085 if ($meth->name eq "method_named") {
2086 $meth = $meth->sv->PV;
2088 $meth = $meth->first;
2089 if ($meth->name eq "const") {
2090 # As of 5.005_58, this case is probably obsoleted by the
2091 # method_named case above
2092 $meth = $meth->sv->PV; # needs to be bare
2094 $meth = $self->deparse($meth, 1);
2097 my $args = join(", ", @exprs);
2098 $kid = $obj . "->" . $meth;
2100 return $kid . "(" . $args . ")"; # parens mandatory
2106 # returns "&" if the prototype doesn't match the args,
2107 # or ("", $args_after_prototype_demunging) if it does.
2110 my($proto, @args) = @_;
2114 # An unbackslashed @ or % gobbles up the rest of the args
2115 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2117 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2120 return "&" if @args;
2121 } elsif ($chr eq ";") {
2123 } elsif ($chr eq "@" or $chr eq "%") {
2124 push @reals, map($self->deparse($_, 6), @args);
2130 if (want_scalar $arg) {
2131 push @reals, $self->deparse($arg, 6);
2135 } elsif ($chr eq "&") {
2136 if ($arg->name =~ /^(s?refgen|undef)$/) {
2137 push @reals, $self->deparse($arg, 6);
2141 } elsif ($chr eq "*") {
2142 if ($arg->name =~ /^s?refgen$/
2143 and $arg->first->first->name eq "rv2gv")
2145 $real = $arg->first->first; # skip refgen, null
2146 if ($real->first->name eq "gv") {
2147 push @reals, $self->deparse($real, 6);
2149 push @reals, $self->deparse($real->first, 6);
2154 } elsif (substr($chr, 0, 1) eq "\\") {
2155 $chr = substr($chr, 1);
2156 if ($arg->name =~ /^s?refgen$/ and
2157 !null($real = $arg->first) and
2158 ($chr eq "\$" && is_scalar($real->first)
2160 && $real->first->sibling->name
2163 && $real->first->sibling->name
2165 #or ($chr eq "&" # This doesn't work
2166 # && $real->first->name eq "rv2cv")
2168 && $real->first->name eq "rv2gv")))
2170 push @reals, $self->deparse($real, 6);
2177 return "&" if $proto and !$doneok; # too few args and no `;'
2178 return "&" if @args; # too many args
2179 return ("", join ", ", @reals);
2185 return $self->method($op, $cx) unless null $op->first->sibling;
2189 if ($op->flags & OPf_SPECIAL) {
2191 } elsif ($op->private & OPpENTERSUB_AMPER) {
2195 $kid = $kid->first->sibling; # skip ex-list, pushmark
2196 for (; not null $kid->sibling; $kid = $kid->sibling) {
2201 if (is_scope($kid)) {
2203 $kid = "{" . $self->deparse($kid, 0) . "}";
2204 } elsif ($kid->first->name eq "gv") {
2205 my $gv = $kid->first->gv;
2206 if (class($gv->CV) ne "SPECIAL") {
2207 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2209 $simple = 1; # only calls of named functions can be prototyped
2210 $kid = $self->deparse($kid, 24);
2211 } elsif (is_scalar $kid->first) {
2213 $kid = $self->deparse($kid, 24);
2216 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2217 $kid = $self->deparse($kid, 24) . $arrow;
2220 if (defined $proto and not $amper) {
2221 ($amper, $args) = $self->check_proto($proto, @exprs);
2222 if ($amper eq "&") {
2223 $args = join(", ", map($self->deparse($_, 6), @exprs));
2226 $args = join(", ", map($self->deparse($_, 6), @exprs));
2228 if ($prefix or $amper) {
2229 if ($op->flags & OPf_STACKED) {
2230 return $prefix . $amper . $kid . "(" . $args . ")";
2232 return $prefix . $amper. $kid;
2235 if (defined $proto and $proto eq "") {
2237 } elsif ($proto eq "\$") {
2238 return $self->maybe_parens_func($kid, $args, $cx, 16);
2239 } elsif ($proto or $simple) {
2240 return $self->maybe_parens_func($kid, $args, $cx, 5);
2242 return "$kid(" . $args . ")";
2247 sub pp_enterwrite { unop(@_, "write") }
2249 # escape things that cause interpolation in double quotes,
2250 # but not character escapes
2253 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2257 # the same, but treat $|, $), and $ at the end of the string differently
2260 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2261 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2265 # character escapes, but not delimiters that might need to be escaped
2266 sub escape_str { # ASCII
2269 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2275 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2276 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2280 # Don't do this for regexen
2283 $str =~ s/\\/\\\\/g;
2287 sub balanced_delim {
2289 my @str = split //, $str;
2290 my($ar, $open, $close, $fail, $c, $cnt);
2291 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2292 ($open, $close) = @$ar;
2293 $fail = 0; $cnt = 0;
2297 } elsif ($c eq $close) {
2306 $fail = 1 if $cnt != 0;
2307 return ($open, "$open$str$close") if not $fail;
2313 my($q, $default, $str) = @_;
2314 return "$default$str$default" if $default and index($str, $default) == -1;
2315 my($succeed, $delim);
2316 ($succeed, $str) = balanced_delim($str);
2317 return "$q$str" if $succeed;
2318 for $delim ('/', '"', '#') {
2319 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2322 $str =~ s/$default/\\$default/g;
2323 return "$default$str$default";
2332 if (class($sv) eq "SPECIAL") {
2333 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2334 } elsif ($sv->FLAGS & SVf_IOK) {
2336 } elsif ($sv->FLAGS & SVf_NOK) {
2338 } elsif ($sv->FLAGS & SVf_ROK) {
2339 return "\\(" . const($sv->RV) . ")"; # constant folded
2342 if ($str =~ /[^ -~]/) { # ASCII for non-printing
2343 return single_delim("qq", '"', uninterp escape_str unback $str);
2345 return single_delim("q", "'", unback $str);
2353 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2354 # return $op->sv->PV;
2356 return const($op->sv);
2362 my $type = $op->name;
2363 if ($type eq "const") {
2364 return uninterp(escape_str(unback($op->sv->PV)));
2365 } elsif ($type eq "concat") {
2366 return $self->dq($op->first) . $self->dq($op->last);
2367 } elsif ($type eq "uc") {
2368 return '\U' . $self->dq($op->first->sibling) . '\E';
2369 } elsif ($type eq "lc") {
2370 return '\L' . $self->dq($op->first->sibling) . '\E';
2371 } elsif ($type eq "ucfirst") {
2372 return '\u' . $self->dq($op->first->sibling);
2373 } elsif ($type eq "lcfirst") {
2374 return '\l' . $self->dq($op->first->sibling);
2375 } elsif ($type eq "quotemeta") {
2376 return '\Q' . $self->dq($op->first->sibling) . '\E';
2377 } elsif ($type eq "join") {
2378 return $self->deparse($op->last, 26); # was join($", @ary)
2380 return $self->deparse($op, 26);
2388 return single_delim("qx", '`', $self->dq($op->first->sibling));
2393 my($op, $cx) = shift;
2394 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2395 return $self->deparse($kid, $cx) if $self->{'unquote'};
2396 $self->maybe_targmy($kid, $cx,
2397 sub {single_delim("qq", '"', $self->dq($_[1]))});
2400 # OP_STRINGIFY is a listop, but it only ever has one arg
2401 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2403 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2404 # note that tr(from)/to/ is OK, but not tr/from/(to)
2406 my($from, $to) = @_;
2407 my($succeed, $delim);
2408 if ($from !~ m[/] and $to !~ m[/]) {
2409 return "/$from/$to/";
2410 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2411 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2414 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2415 return "$from$delim$to$delim" if index($to, $delim) == -1;
2418 return "$from/$to/";
2421 for $delim ('/', '"', '#') { # note no '
2422 return "$delim$from$delim$to$delim"
2423 if index($to . $from, $delim) == -1;
2425 $from =~ s[/][\\/]g;
2427 return "/$from/$to/";
2433 if ($n == ord '\\') {
2435 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2437 } elsif ($n == ord "\a") {
2439 } elsif ($n == ord "\b") {
2441 } elsif ($n == ord "\t") {
2443 } elsif ($n == ord "\n") {
2445 } elsif ($n == ord "\e") {
2447 } elsif ($n == ord "\f") {
2449 } elsif ($n == ord "\r") {
2451 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2452 return '\\c' . chr(ord("@") + $n);
2454 # return '\x' . sprintf("%02x", $n);
2455 return '\\' . sprintf("%03o", $n);
2462 for ($c = 0; $c < @chars; $c++) {
2465 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2466 $chars[$c + 2] == $tr + 2)
2468 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
2471 $str .= pchr($chars[$c]);
2477 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
2480 sub tr_decode_byte {
2481 my($table, $flags) = @_;
2482 my(@table) = unpack("s256", $table);
2483 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2484 if ($table[ord "-"] != -1 and
2485 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2487 $tr = $table[ord "-"];
2488 $table[ord "-"] = -1;
2492 } else { # -2 ==> delete
2496 for ($c = 0; $c < 256; $c++) {
2499 push @from, $c; push @to, $tr;
2500 } elsif ($tr == -2) {
2504 @from = (@from, @delfrom);
2505 if ($flags & OPpTRANS_COMPLEMENT) {
2508 @from{@from} = (1) x @from;
2509 for ($c = 0; $c < 256; $c++) {
2510 push @newfrom, $c unless $from{$c};
2514 unless ($flags & OPpTRANS_DELETE) {
2515 pop @to while $#to and $to[$#to] == $to[$#to -1];
2518 $from = collapse(@from);
2519 $to = collapse(@to);
2520 $from .= "-" if $delhyphen;
2521 return ($from, $to);
2526 if ($x == ord "-") {
2533 # XXX This doesn't yet handle all cases correctly either
2535 sub tr_decode_utf8 {
2536 my($swash_hv, $flags) = @_;
2537 my %swash = $swash_hv->ARRAY;
2539 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
2540 my $none = $swash{"NONE"}->IV;
2541 my $extra = $none + 1;
2542 my(@from, @delfrom, @to);
2544 foreach $line (split /\n/, $swash{'LIST'}->PV) {
2545 my($min, $max, $result) = split(/\t/, $line);
2552 $result = hex $result;
2553 if ($result == $extra) {
2554 push @delfrom, [$min, $max];
2556 push @from, [$min, $max];
2557 push @to, [$result, $result + $max - $min];
2560 for my $i (0 .. $#from) {
2561 if ($from[$i][0] == ord '-') {
2562 unshift @from, splice(@from, $i, 1);
2563 unshift @to, splice(@to, $i, 1);
2565 } elsif ($from[$i][1] == ord '-') {
2568 unshift @from, ord '-';
2569 unshift @to, ord '-';
2573 for my $i (0 .. $#delfrom) {
2574 if ($delfrom[$i][0] == ord '-') {
2575 push @delfrom, splice(@delfrom, $i, 1);
2577 } elsif ($delfrom[$i][1] == ord '-') {
2579 push @delfrom, ord '-';
2583 if (defined $final and $to[$#to][1] != $final) {
2584 push @to, [$final, $final];
2586 push @from, @delfrom;
2587 if ($flags & OPpTRANS_COMPLEMENT) {
2590 for my $i (0 .. $#from) {
2591 push @newfrom, [$next, $from[$i][0] - 1];
2592 $next = $from[$i][1] + 1;
2595 for my $range (@newfrom) {
2596 if ($range->[0] <= $range->[1]) {
2601 my($from, $to, $diff);
2602 for my $chunk (@from) {
2603 $diff = $chunk->[1] - $chunk->[0];
2605 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2606 } elsif ($diff == 1) {
2607 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2609 $from .= tr_chr($chunk->[0]);
2612 for my $chunk (@to) {
2613 $diff = $chunk->[1] - $chunk->[0];
2615 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2616 } elsif ($diff == 1) {
2617 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2619 $to .= tr_chr($chunk->[0]);
2622 #$final = sprintf("%04x", $final) if defined $final;
2623 #$none = sprintf("%04x", $none) if defined $none;
2624 #$extra = sprintf("%04x", $extra) if defined $extra;
2625 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
2626 #print STDERR $swash{'LIST'}->PV;
2627 return (escape_str($from), escape_str($to));
2634 if (class($op) eq "PVOP") {
2635 ($from, $to) = tr_decode_byte($op->pv, $op->private);
2636 } else { # class($op) eq "SVOP"
2637 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
2640 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
2641 $flags .= "d" if $op->private & OPpTRANS_DELETE;
2642 $to = "" if $from eq $to and $flags eq "";
2643 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2644 return "tr" . double_delim($from, $to) . $flags;
2647 # Like dq(), but different
2651 my $type = $op->name;
2652 if ($type eq "const") {
2653 return uninterp($op->sv->PV);
2654 } elsif ($type eq "concat") {
2655 return $self->re_dq($op->first) . $self->re_dq($op->last);
2656 } elsif ($type eq "uc") {
2657 return '\U' . $self->re_dq($op->first->sibling) . '\E';
2658 } elsif ($type eq "lc") {
2659 return '\L' . $self->re_dq($op->first->sibling) . '\E';
2660 } elsif ($type eq "ucfirst") {
2661 return '\u' . $self->re_dq($op->first->sibling);
2662 } elsif ($type eq "lcfirst") {
2663 return '\l' . $self->re_dq($op->first->sibling);
2664 } elsif ($type eq "quotemeta") {
2665 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2666 } elsif ($type eq "join") {
2667 return $self->deparse($op->last, 26); # was join($", @ary)
2669 return $self->deparse($op, 26);
2676 my $kid = $op->first;
2677 $kid = $kid->first if $kid->name eq "regcmaybe";
2678 $kid = $kid->first if $kid->name eq "regcreset";
2679 return $self->re_dq($kid);
2682 # osmic acid -- see osmium tetroxide
2685 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2686 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2687 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2691 my($op, $cx, $name, $delim) = @_;
2692 my $kid = $op->first;
2693 my ($binop, $var, $re) = ("", "", "");
2694 if ($op->flags & OPf_STACKED) {
2696 $var = $self->deparse($kid, 20);
2697 $kid = $kid->sibling;
2700 $re = re_uninterp(escape_str($op->precomp));
2702 $re = $self->deparse($kid, 1);
2705 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2706 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2707 $flags .= "i" if $op->pmflags & PMf_FOLD;
2708 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2709 $flags .= "o" if $op->pmflags & PMf_KEEP;
2710 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2711 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2712 $flags = $matchwords{$flags} if $matchwords{$flags};
2713 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2717 $re = single_delim($name, $delim, $re);
2721 return $self->maybe_parens("$var =~ $re", $cx, 20);
2727 sub pp_match { matchop(@_, "m", "/") }
2728 sub pp_pushre { matchop(@_, "m", "/") }
2729 sub pp_qr { matchop(@_, "qr", "") }
2734 my($kid, @exprs, $ary, $expr);
2736 if ($ {$kid->pmreplroot}) {
2737 $ary = '@' . $self->gv_name($kid->pmreplroot);
2739 for (; !null($kid); $kid = $kid->sibling) {
2740 push @exprs, $self->deparse($kid, 6);
2742 $expr = "split(" . join(", ", @exprs) . ")";
2744 return $self->maybe_parens("$ary = $expr", $cx, 7);
2750 # oxime -- any of various compounds obtained chiefly by the action of
2751 # hydroxylamine on aldehydes and ketones and characterized by the
2752 # bivalent grouping C=NOH [Webster's Tenth]
2755 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2756 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2757 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2758 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2763 my $kid = $op->first;
2764 my($binop, $var, $re, $repl) = ("", "", "", "");
2765 if ($op->flags & OPf_STACKED) {
2767 $var = $self->deparse($kid, 20);
2768 $kid = $kid->sibling;
2771 if (null($op->pmreplroot)) {
2772 $repl = $self->dq($kid);
2773 $kid = $kid->sibling;
2775 $repl = $op->pmreplroot->first; # skip substcont
2776 while ($repl->name eq "entereval") {
2777 $repl = $repl->first;
2780 if ($op->pmflags & PMf_EVAL) {
2781 $repl = $self->deparse($repl, 0);
2783 $repl = $self->dq($repl);
2787 $re = re_uninterp(escape_str($op->precomp));
2789 $re = $self->deparse($kid, 1);
2791 $flags .= "e" if $op->pmflags & PMf_EVAL;
2792 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2793 $flags .= "i" if $op->pmflags & PMf_FOLD;
2794 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2795 $flags .= "o" if $op->pmflags & PMf_KEEP;
2796 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2797 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2798 $flags = $substwords{$flags} if $substwords{$flags};
2800 return $self->maybe_parens("$var =~ s"
2801 . double_delim($re, $repl) . $flags,
2804 return "s". double_delim($re, $repl) . $flags;
2813 B::Deparse - Perl compiler backend to produce perl code
2817 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>][B<,-s>I<LETTERS>]
2822 B::Deparse is a backend module for the Perl compiler that generates
2823 perl source code, based on the internal compiled structure that perl
2824 itself creates after parsing a program. The output of B::Deparse won't
2825 be exactly the same as the original source, since perl doesn't keep
2826 track of comments or whitespace, and there isn't a one-to-one
2827 correspondence between perl's syntactical constructions and their
2828 compiled form, but it will often be close. When you use the B<-p>
2829 option, the output also includes parentheses even when they are not
2830 required by precedence, which can make it easy to see if perl is
2831 parsing your expressions the way you intended.
2833 Please note that this module is mainly new and untested code and is
2834 still under development, so it may change in the future.
2838 As with all compiler backend options, these must follow directly after
2839 the '-MO=Deparse', separated by a comma but not any white space.
2845 Add '#line' declarations to the output based on the line and file
2846 locations of the original code.
2850 Print extra parentheses. Without this option, B::Deparse includes
2851 parentheses in its output only when they are needed, based on the
2852 structure of your program. With B<-p>, it uses parentheses (almost)
2853 whenever they would be legal. This can be useful if you are used to
2854 LISP, or if you want to see how perl parses your input. If you say
2856 if ($var & 0x7f == 65) {print "Gimme an A!"}
2857 print ($which ? $a : $b), "\n";
2858 $name = $ENV{USER} or "Bob";
2860 C<B::Deparse,-p> will print
2863 print('Gimme an A!')
2865 (print(($which ? $a : $b)), '???');
2866 (($name = $ENV{'USER'}) or '???')
2868 which probably isn't what you intended (the C<'???'> is a sign that
2869 perl optimized away a constant value).
2873 Expand double-quoted strings into the corresponding combinations of
2874 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
2877 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
2881 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
2882 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
2884 Note that the expanded form represents the way perl handles such
2885 constructions internally -- this option actually turns off the reverse
2886 translation that B::Deparse usually does. On the other hand, note that
2887 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
2888 of $y into a string before doing the assignment.
2890 =item B<-u>I<PACKAGE>
2892 Normally, B::Deparse deparses the main code of a program, all the subs
2893 called by the main program (and all the subs called by them,
2894 recursively), and any other subs in the main:: package. To include
2895 subs in other packages that aren't called directly, such as AUTOLOAD,
2896 DESTROY, other subs called automatically by perl, and methods (which
2897 aren't resolved to subs until runtime), use the B<-u> option. The
2898 argument to B<-u> is the name of a package, and should follow directly
2899 after the 'u'. Multiple B<-u> options may be given, separated by
2900 commas. Note that unlike some other backends, B::Deparse doesn't
2901 (yet) try to guess automatically when B<-u> is needed -- you must
2904 =item B<-s>I<LETTERS>
2906 Tweak the style of B::Deparse's output. The letters should follow
2907 directly after the 's', with no space or punctuation. The following
2908 options are available:
2914 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2931 The default is not to cuddle.
2935 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
2939 Use tabs for each 8 columns of indent. The default is to use only spaces.
2940 For instance, if the style options are B<-si4T>, a line that's indented
2941 3 times will be preceded by one tab and four spaces; if the options were
2942 B<-si8T>, the same line would be preceded by three tabs.
2944 =item B<v>I<STRING>B<.>
2946 Print I<STRING> for the value of a constant that can't be determined
2947 because it was optimized away (mnemonic: this happens when a constant
2948 is used in B<v>oid context). The end of the string is marked by a period.
2949 The string should be a valid perl expression, generally a constant.
2950 Note that unless it's a number, it probably needs to be quoted, and on
2951 a command line quotes need to be protected from the shell. Some
2952 conventional values include 0, 1, 42, '', 'foo', and
2953 'Useless use of constant omitted' (which may need to be
2954 B<-sv"'Useless use of constant omitted'.">
2955 or something similar depending on your shell). The default is '???'.
2956 If you're using B::Deparse on a module or other file that's require'd,
2957 you shouldn't use a value that evaluates to false, since the customary
2958 true constant at the end of a module will be in void context when the
2959 file is compiled as a main program.
2965 =head1 USING B::Deparse AS A MODULE
2970 $deparse = B::Deparse->new("-p", "-sC");
2971 $body = $deparse->coderef2text(\&func);
2972 eval "sub func $body"; # the inverse operation
2976 B::Deparse can also be used on a sub-by-sub basis from other perl
2981 $deparse = B::Deparse->new(OPTIONS)
2983 Create an object to store the state of a deparsing operation and any
2984 options. The options are the same as those that can be given on the
2985 command line (see L</OPTIONS>); options that are separated by commas
2986 after B<-MO=Deparse> should be given as separate strings. Some
2987 options, like B<-u>, don't make sense for a single subroutine, so
2992 $body = $deparse->coderef2text(\&func)
2993 $body = $deparse->coderef2text(sub ($$) { ... })
2995 Return source code for the body of a subroutine (a block, optionally
2996 preceded by a prototype in parens), given a reference to the
2997 sub. Because a subroutine can have no names, or more than one name,
2998 this method doesn't return a complete subroutine definition -- if you
2999 want to eval the result, you should prepend "sub subname ", or "sub "
3000 for an anonymous function constructor. Unless the sub was defined in
3001 the main:: package, the code will include a package declaration.
3005 See the 'to do' list at the beginning of the module file.
3009 Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier
3010 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3011 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3012 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.